raster_2.3-0_(2014-9-5_by_Robert-J.-Hijmans-[cre,-aut],)

Table of Contents

1 AAAClasses.R

# R classes for raster (grid) type spatial data
# Robert J. Hijmans, r.hijmans@gmail.com
# November 2008
# Version 1.0
# Licence GPL v3
setClass('Extent',
        representation (
                xmin = 'numeric',
                xmax = 'numeric',
                ymin = 'numeric',
                ymax = 'numeric'
        ),      
        prototype (     
                xmin = 0,
                xmax = 1,
                ymin = 0,
                ymax = 1
        ),
        validity = function(object)     {
                c1 <- (object@xmin <= object@xmax)
                if (!c1) { stop('invalid extent: xmin >= xmax') }
                c2 <- (object@ymin <= object@ymax)
                if (!c2) { stop('invalid extent: ymin >= ymax') }
                v <- c(object@xmin, object@xmax, object@ymin, object@ymax)
                c3 <- all(!is.infinite(v))
                if (!c3) { stop('invalid extent: infinite value') }             
                return(c1 & c2 & c3)
        }
)
setClass('.Rotation',
        representation (
                geotrans = 'numeric',
                transfun = 'function'
        )
)
setClass ('BasicRaster',
        representation (
                title = 'character',
                extent = 'Extent',
                rotated = 'logical',
                rotation = '.Rotation',
                ncols ='integer',
                nrows ='integer',
                crs = 'CRS',
                history = 'list',
                #meta = 'list',
                z = 'list'
        ),
        prototype (     
                rotated = FALSE,
                ncols= as.integer(1),
                nrows= as.integer(1),
                crs = CRS(),
                history = list(),
                #meta = list(),
                z = list()
        ),
        validity = function(object) {
                validObject(extent(object))
                c1 <- (object@ncols > 0)
                if (!c1) { stop('ncols < 1') }
                c2 <- (object@nrows > 0)
                if (!c2) { stop('nrows < 1') }          
                return(c1 & c2)
        }
)
setClass ('Raster', contains = c('BasicRaster', 'VIRTUAL') )

setClass('.RasterFile', 
        representation (
                name ='character',
                datanotation='character',
                byteorder ='character',
                nodatavalue ='numeric', # on disk, in ram it is NA
                NAchanged ='logical',
                nbands ='integer',
                bandorder ='character',
                offset='integer',
                toptobottom='logical',
                blockrows='integer',
                blockcols='integer',
                driver ='character',
                open = 'logical'
                ),
        prototype (     
            name = '',
                datanotation='FLT4S',
                byteorder = .Platform$endian,
                nodatavalue = -Inf,
                NAchanged = FALSE,
                nbands = as.integer(1),
                bandorder = 'BIL',
                offset = as.integer(0),
                toptobottom = TRUE,
                blockrows = as.integer(0),
                blockcols= as.integer(0),
                driver = '', 
                open = FALSE
        ),
        validity = function(object) {
                c1 <- datanotation %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S')
                return(c1)
        }
)
setClass('.SingleLayerData', 
        representation (
                values='vector', 
                offset='numeric',
                gain='numeric',

                inmemory='logical',
                fromdisk='logical',

                isfactor = 'logical',
                attributes = 'list',

                haveminmax = 'logical',
                min = 'vector',
                max = 'vector',
                band = 'integer',
                unit = 'character',
                names = 'vector'
                ),
        prototype (     
                values=vector(),
                offset=0,
                gain=1,

                inmemory=FALSE,
                fromdisk=FALSE,
                isfactor = FALSE,
                attributes = list(),

                haveminmax = FALSE,
                min = c(Inf),
                max = c(-Inf),
                band = as.integer(1),
                unit = '',
                names=c()

        ),      
        validity = function(object) {
        }
)
setClass ('.RasterLegend',
        representation (
                type = 'character',
                values = 'vector',
                color = 'vector',
                names = 'vector',
                colortable = 'vector'
                ),
        prototype (
                )
        )


setClass ('RasterLayer',
        contains = 'Raster',
        representation (
                file = '.RasterFile',
                data = '.SingleLayerData',
                legend = '.RasterLegend'
        )
)
setClass('.MultipleRasterData', 
        representation (
                values='matrix', 
                offset='numeric',
                gain='numeric',
                inmemory='logical',
                fromdisk='logical',
                nlayers='integer',
                dropped = 'vector',
                isfactor = 'logical',
                attributes = 'list',
                haveminmax = 'logical',
                min = 'vector',
                max = 'vector',
                unit = 'vector',
                names= 'vector'

                ),
        prototype (     
                values=matrix(NA,0,0),
                offset=0,
                gain=1,
                #indices =vector(mode='numeric'),
                inmemory=FALSE,
                fromdisk=FALSE,
                nlayers=as.integer(0),
                dropped=NULL,
                isfactor = FALSE,
                attributes = list(),
                haveminmax = FALSE,
                min = c(Inf),
                max = c(-Inf),
                unit = c(''),
                names = c('')
        ),      
        validity = function(object) {
        }
)
setClass ('RasterBrick',
        contains = 'Raster',
        representation (
                file = '.RasterFile',
                data = '.MultipleRasterData',
                legend = '.RasterLegend'
        )
)


setClass ('RasterStack',
        contains = 'Raster',
        representation (
            filename ='character',
                layers ='list'
                ),
        prototype (
                filename='',
                layers = list()
                ),
        validity = function(object) {
                if (length(object@layers) > 1) {
                        cond <- compareRaster(object@layers, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) 
                } else {
                        cond <- TRUE
                }
                return(cond)
        }
)
setClassUnion(RasterStackBrick, c(RasterStack, RasterBrick))
setClass ('RasterLayerSparse',
        contains = 'RasterLayer',
        representation (
                index = 'vector'
        ),
        prototype (
                index = vector(mode='numeric')
        )
)       
setClass ('.RasterBrickSparse',
        contains = 'RasterBrick',
        representation (
                index = 'vector'
        ),
        prototype (
                index = vector(mode='numeric')
        )
)       
setClass ('.RasterQuad',
        contains = 'Raster',
        representation (
            filename ='character',
                bricks ='list'
                ),
        prototype (
                filename='',
                bricks = list()
                ),
        validity = function(object) {
                if (length(object@bricks) > 1) {
                        test <- compareRaster(object@bricks, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) 
                } else {
                        test <- TRUE
                }
                return(test)
        }
)
#setClassUnion(RasterStackBrickList, c(RasterStack, RasterBrick, RasterList))
setClass ('.RasterList',
        contains = 'list',
        representation (),
        prototype (),
        validity = function(object) {
                s <- sapply(object, function(x) inherits(x, 'Raster'))
                return( sum(s) == length(s))
        }
)

2 addFiles.R

# Author: Robert J. Hijmans
# Date : June 2008
# Version 0.9
# Licence GPL v3
.addFiles <- function(x, rasterfiles, bands=rep(1, length(rasterfiles))) {
        if (length(bands) == 1) {
                bands=rep(bands, length(rasterfiles))
        } 
        rasters <- list()
        for (i in 1:length(rasterfiles)) { 
                if (bands[[i]] < 1) {
                        r <- raster(rasterfiles[[i]], band=1)
                        rasters <- c(rasters, r)
                        if (nbands(r) > 1) {
                                for (j in 2:nbands(r)) {
                                        r <- raster(rasterfiles[[i]], band=j)
                                        rasters <- c(rasters, r)
                                }
                        }
                } else {
                        rasters <- c(rasters, raster(rasterfiles[[i]], FALSE, band=bands[[i]]))
                }
        }       
        x <- addLayer(x, rasters) 
        return(x)
}

3 addLayer.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2009
# Version 0.9
# Licence GPL v3

if (!isGeneric(addLayer)) {
        setGeneric(addLayer, function(x, ...)
                standardGeneric(addLayer))
}       
setMethod('addLayer', signature(x='Raster'), 
function(x, ...) {
        rasters <- .makeRasterList(...)
        if (! inherits(x, 'RasterStack')) {
                x <- stack(x)
        }
        if (length(rasters)==0) { 
                return(x) 
        }
        if (nlayers(x) > 0) {
                compareRaster(c(x, rasters))
        } else if (length(rasters) > 1) {
                compareRaster(rasters)
        }

        vals <- sapply(rasters, hasValues) 
        if (sum(vals) == 0 &  nlayers(x) == 0) { 
                vals[1] <- TRUE 
        }
        if (sum(vals) != length(vals)) { 
                warning('Cannot add a RasterLayer with no associated data in memory or on disk to a RasterStack')
        }
        rasters <- rasters[vals]

        if (nlayers(x) == 0) {
                r <- rasters[[1]]
                x@nrows <- r@nrows
                x@ncols <- r@ncols
                x@extent <- r@extent
                x@crs <- r@crs
                if (rotated(r)) {
                        x@rotated = r@rotated
                        x@rotation = r@rotation
                }
                nl <- 1
                x@layers[nl] <- r 
                rasters <- rasters[-1]
                if (length(rasters)==0) { return(x) }
        }
        x@layers <- c(x@layers, rasters)
        names(x) <- sapply(x@layers, names)
        return(x)
}       
)

4 adjacency.R

# Author: Jacob van Etten jacobvanetten@yahoo.com
# Date :  January 2009
# Version 0.9
# Licence GPL v3
.cs <- function(a,b) {
        aRep <- rep(a,times=length(b))
        cbind(aRep,as.integer(aRep+rep(b,each=length(a))),deparse.level=0)
}
.adjacency <- function(x, ...) {
        warning('function adjaceny is obsolete and will be removed from the raster package.\nUse function adjacent in stead')
        dots <- list(...)
        fromCells <- dots$fromCells
        toCells <- dots$toCells
        directions <- dots$directions 

        if (is.character(directions)) { directions <- tolower(directions) }
        stopifnot(directions %in% c(4,8,16) | directions=='bishop')
        x <- raster(x)
        outerMeridianConnect <- .isGlobalLonLat(x)

        if (directions==bishop) { 
                return(.adjBishop(x, fromCells, toCells, outerMeridianConnect)) 
        }

        nCols <- ncol(x)
        nCells <- ncell(x)

        left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) 
        right <- seq(2*nCols,nCells-nCols,by=nCols)
        upper <- 2:(nCols-1)
        lower <- seq((nCells-nCols+2),(nCells-1),by=1)
        upperleft <- 1
        upperright <- nCols
        lowerleft <- nCells-nCols+1
        lowerright <- nCells
        fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright))))
        fromCellsUpper <- as.integer(intersect(fromCells,upper))
        fromCellsLower <- as.integer(intersect(fromCells,lower))
        fromCellsLeft <- as.integer(intersect(fromCells,left))
        fromCellsRight <- as.integer(intersect(fromCells,right))
        fromCellUpperleft <- as.integer(intersect(fromCells,upperleft))
        fromCellUpperright <- as.integer(intersect(fromCells,upperright))
        fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft))
        fromCellLowerright <- as.integer(intersect(fromCells,lowerright))
        rook <- c(1,-1,nCols,-nCols)
        coreFromToRook <- .cs(fromCellsCore,rook)
        upperFromToRook <- .cs(fromCellsUpper,rook[1:3])
        lowerFromToRook <- .cs(fromCellsLower,rook[c(1,2,4)])
        leftFromToRook <- .cs(fromCellsLeft,rook[c(1,3,4)])
        rightFromToRook <- .cs(fromCellsRight,rook[2:4])
        upperleftFromToRook <- .cs(fromCellUpperleft,rook[c(1,3)])
        upperrightFromToRook <- .cs(fromCellUpperright,rook[2:3])
        lowerleftFromToRook <- .cs(fromCellLowerleft,rook[c(1,4)])
        lowerrightFromToRook <- .cs(fromCellLowerright,rook[c(2,4)])
        fromto1 <- rbind(coreFromToRook,upperFromToRook,lowerFromToRook,leftFromToRook,rightFromToRook,upperleftFromToRook,upperrightFromToRook,lowerleftFromToRook,lowerrightFromToRook)

        if (outerMeridianConnect) {
                meridianFromLeft <- rbind(
                        cbind(fromCellsLeft,as.integer(fromCellsLeft+nCols-1)),
                        cbind(fromCellUpperleft,as.integer(fromCellUpperleft+nCols-1)),
                        cbind(fromCellLowerleft,as.integer(fromCellLowerleft+nCols-1))
                        )
                meridianFromRight <- rbind(
                        cbind(fromCellsRight,as.integer(fromCellsRight-nCols+1)),
                        cbind(fromCellUpperright,as.integer(fromCellUpperright-nCols+1)),
                        cbind(fromCellLowerright,as.integer(fromCellLowerright-nCols+1))
                        )
                fromto1 <- rbind(fromto1,meridianFromLeft,meridianFromRight)
        }
        fromto <- subset(fromto1,fromto1[,2] %in% toCells)
        if (directions > 4)     {
                bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1))

                coreFromToBishop <- .cs(fromCellsCore,bishop)
                upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4])
                lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2])
                leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)])
                rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)])
                upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4])
                upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3])
                lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2])
                lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1])
                fromto2 <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop)

                if (outerMeridianConnect) {
                        meridianFromLeft <- rbind(
                                .cs(fromCellsLeft,c(2*nCols-1,-1)),
                                cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)),
                                cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1))
                                ) 
                        meridianFromRight <- rbind(
                                cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))),
                                cbind(fromCellUpperright,as.integer(fromCellUpperright+1)),
                                cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1))
                                )
                        fromto2 <- rbind(fromto2,meridianFromLeft,meridianFromRight)
                }
                fromto2 <- subset(fromto2,fromto2[,2] %in% toCells)
                fromto <- rbind(fromto,fromto2)
        }
        if (directions > 8) {
                leftOuter <- seq(2*nCols+1,nCells-3*nCols+1,by=nCols) 
                rightOuter <- seq(3*nCols,nCells-2*nCols,by=nCols)
                upperOuter <- seq(3,nCols-2,by=1)
                lowerOuter <- seq(nCells-nCols+3,nCells-2,by=1)
                upperleftUnder <- nCols+1
                upperrightLeft <- nCols-1
                lowerleftUp <- nCells-2*nCols+1
                lowerrightUp <- nCells-nCols            
                upperleftRight <- 2
                upperrightUnder <- 2*nCols
                lowerleftRight <- nCells-nCols+2
                lowerrightLeft <- nCells-1
                leftInner <- seq(2*nCols+2,(nCells-3*nCols+2),by=nCols) 
                rightInner <- seq(3*nCols-1,nCells-2*nCols-1,by=nCols)
                upperInner <- seq(nCols+3,2*nCols-2,by=1)
                lowerInner <- seq(nCells-2*nCols+3,nCells-nCols-2,by=1)
                upperleftInner <- nCols+2
                upperrightInner <- 2*nCols-1
                lowerleftInner <- nCells-2*nCols+2
                lowerrightInner <- nCells-nCols-1
                fromCellsCoreInner <- setdiff(fromCells,(c(leftOuter,rightOuter,upperOuter,lowerOuter,upperleft,upperright,lowerleft,lowerright, upperleftUnder, upperrightLeft, lowerleftUp, lowerrightUp, upperleftRight, upperrightUnder, lowerleftRight, lowerrightLeft, leftInner, rightInner, upperInner, lowerInner, upperleftInner, upperrightInner, lowerleftInner, lowerrightInner))) 

                fromCellsUpperInner <- as.integer(intersect(fromCells,upperInner))
                fromCellsLowerInner <- as.integer(intersect(fromCells,lowerInner))
                fromCellsLeftInner <- as.integer(intersect(fromCells,leftInner))
                fromCellsRightInner <- as.integer(intersect(fromCells,rightInner))
                fromCellUpperleftInner <- as.integer(intersect(fromCells,upperleftInner))
                fromCellUpperrightInner <- as.integer(intersect(fromCells,upperrightInner))
                fromCellLowerleftInner <- as.integer(intersect(fromCells,lowerleftInner))
                fromCellLowerrightInner <- as.integer(intersect(fromCells,lowerrightInner))     
                fromCellsLeftOuter <- as.integer(intersect(fromCells,leftOuter))
                fromCellsRightOuter <- as.integer(intersect(fromCells,rightOuter))
                fromCellsUpperOuter <- as.integer(intersect(fromCells,upperOuter))
                fromCellsLowerOuter <- as.integer(intersect(fromCells,lowerOuter))
                fromCellUpperleftUnder <- as.integer(intersect(fromCells,upperleftUnder))
                fromCellUpperrightLeft <- as.integer(intersect(fromCells,upperrightLeft))
                fromCellLowerleftUp <- as.integer(intersect(fromCells,lowerleftUp))
                fromCellLowerrightUp <- as.integer(intersect(fromCells,lowerrightUp))
                fromCellUpperleftRight <- as.integer(intersect(fromCells,upperleftRight))
                fromCellUpperrightUnder <- as.integer(intersect(fromCells,upperrightUnder))
                fromCellLowerleftRight <- as.integer(intersect(fromCells,lowerleftRight))
                fromCellLowerrightLeft <- as.integer(intersect(fromCells,lowerrightLeft))
                knight <- c(-2*nCols-1, -2*nCols+1, -nCols-2, -nCols+2, nCols-2, nCols+2, 2*nCols-1, 2*nCols+1) 

                coreInnerFromToKnight <- .cs(fromCellsCoreInner, knight) 

                upperInnerFromToKnight <- .cs(fromCellsUpperInner, knight[3:8])
                lowerInnerFromToKnight <- .cs(fromCellsLowerInner, knight[1:6])
                leftInnerFromToKnight <- .cs(fromCellsLeftInner, knight[c(1,2,4,6:8)])
                rightInnerFromToKnight <- .cs(fromCellsRightInner, knight[c(1:3,5,7,8)])
                upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knight[c(4,6:8)])
                upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knight[c(3,5,7,8)])
                lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knight[c(1,2,4,6)])
                lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knight[c(1:3,5)])

                leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knight[c(2,4,6,8)])
                rightOuterFromToKnight <- .cs(fromCellsRightOuter, knight[c(1,3,5,7)])
                upperOuterFromToKnight <- .cs(fromCellsUpperOuter, knight[5:8])
                lowerOuterFromToKnight <- .cs(fromCellsLowerOuter, knight[1:4])
                upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knight[c(4,6,8)])
                upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knight[c(5,7,8)])
                lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knight[c(2,4,6)])
                lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knight[c(1,3,5)])
                upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knight[6:8])
                upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knight[c(3,5,7)])
                lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knight[c(1,2,4)])
                lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knight[1:3])
                upperleftFromToKnight <- .cs(fromCellUpperleft, knight[c(6,8)])
                upperrightFromToKnight <- .cs(fromCellUpperright, knight[c(5,7)])
                lowerleftFromToKnight <- .cs(fromCellLowerleft, knight[c(2,4)])
                lowerrightFromToKnight <- .cs(fromCellLowerright, knight[c(1,3)])

                fromto3 <- rbind(coreInnerFromToKnight, upperInnerFromToKnight, lowerInnerFromToKnight, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperOuterFromToKnight, lowerOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight)
                fromto3 <- subset(fromto3,fromto3[,2] %in% toCells)

                if (outerMeridianConnect) {
                        knightLeft <- c(-nCols-1, -2, +2*nCols-2, 3*nCols-1)
                        knightRight <- c(-3*nCols+1, -2*nCols+2, +2, nCols+1)
                        leftInnerFromToKnight <- .cs(fromCellsLeftInner, knightLeft[c(2,3)])
                        rightInnerFromToKnight <- .cs(fromCellsRightInner, knightRight[c(2,3)])
                        upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knightLeft[c(2,3)])
                        upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knightRight[c(2,3)])
                        lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knightLeft[c(2,3)])
                        lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knightRight[c(2,3)])

                        leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knightLeft)
                        rightOuterFromToKnight <- .cs(fromCellsRightOuter, knightRight)
                        upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knightLeft[2:4])
                        upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knightRight[3])
                        lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knightLeft[1:3])
                        lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knightRight[1:3])
                        upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knightLeft[c(3)])
                        upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knightRight[2:4])
                        lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knightLeft[2])
                        lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knightRight[2])
                        upperleftFromToKnight <- .cs(fromCellUpperleft, knightLeft[c(3,4)])
                        upperrightFromToKnight <- .cs(fromCellUpperright, knightRight[c(3,4)])
                        lowerleftFromToKnight <- .cs(fromCellLowerleft, knightLeft[c(1,2)])
                        lowerrightFromToKnight <- .cs(fromCellLowerright, knightRight[c(1,2)])

                        fromto3 <- rbind(fromto3, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight)
                }

                fromto3 <- subset(fromto3,fromto3[,2] %in% toCells)     
                fromto <- rbind(fromto,fromto3)
        }
        colnames(fromto) <- c(from,to)
        return(fromto)
}
.adjBishop <- function(raster, fromCells, toCells, outerMeridianConnect)  {
        nCols <- ncol(raster)
        nCells <- ncell(raster)

        left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) 
        right <- seq(2*nCols,nCells-nCols,by=nCols)
        upper <- 2:(nCols-1)
        lower <- seq((nCells-nCols+2),(nCells-1),by=1)
        upperleft <- 1
        upperright <- nCols
        lowerleft <- nCells-nCols+1
        lowerright <- nCells
        fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright))))
        fromCellsUpper <- as.integer(intersect(fromCells,upper))
        fromCellsLower <- as.integer(intersect(fromCells,lower))
        fromCellsLeft <- as.integer(intersect(fromCells,left))
        fromCellsRight <- as.integer(intersect(fromCells,right))
        fromCellUpperleft <- as.integer(intersect(fromCells,upperleft))
        fromCellUpperright <- as.integer(intersect(fromCells,upperright))
        fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft))
        fromCellLowerright <- as.integer(intersect(fromCells,lowerright))

        bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1))

        coreFromToBishop <- .cs(fromCellsCore,bishop)
        upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4])
        lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2])
        leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)])
        rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)])
        upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4])
        upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3])
        lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2])
        lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1])
        fromto <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop)

        if (outerMeridianConnect) {
                meridianFromLeft <- rbind(
                        .cs(fromCellsLeft,c(2*nCols-1,-1)),
                        cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)),
                        cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1))
                        ) 
                meridianFromRight <- rbind(
                        cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))),
                        cbind(fromCellUpperright,as.integer(fromCellUpperright+1)),
                        cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1))
                        )
                fromto <- rbind(fromto,meridianFromLeft,meridianFromRight)
        }
        fromto <- subset(fromto,fromto[,2] %in% toCells)
        return(fromto)
}

5 adjacent.R

# Author: Robert J. Hijmans
# Date :  September 2011
# Version 1.0
# Licence GPL v3
.adjacentUD <- function(x, cells, ngb, include) {
        # ngb should be a matrix with 
        # one and only one cell with value 0 (the focal cell), 
        # at least one cell with value 1 (the adjacent cells)
        # cells with other values are ignored (not considered adjacent)
        rs <- res(x)
        rn <- raster(ngb)
        center <- which(values(rn)==0)
        if (include) {
                ngb[center] <- 1
        }
        rc <- rowFromCell(rn, center)
        cc <- colFromCell(rn, center)

        xngb <- yngb <- ngb
        xngb[] <- rep(1:ncol(ngb), each=nrow(ngb)) - cc 
        yngb[] <- rep(nrow(ngb):1, ncol(ngb)) - (nrow(ngb)-rc+1)
        ngb[ngb != 1] <- NA
        xngb <- na.omit(as.vector( xngb * rs[1] * ngb))
        yngb <- na.omit(as.vector( yngb * rs[2] * ngb))

        xy <- xyFromCell(x, cells)
        X <- apply(xy[,1,drop=FALSE], 1, function(z) z + xngb )
        Y <- apply(xy[,2,drop=FALSE], 1, function(z) z + yngb )
        c(as.vector(X), as.vector(Y))
}
adjacent <- function(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE) {
        if (is.character(directions)) { 
                directions <- tolower(directions) 
        }
        x <- raster(x)
        r <- res(x)
        xy <- xyFromCell(x, cells)
        mat <- FALSE
        if (is.matrix(directions)) {
                stopifnot(length(which(directions==0)) == 1)
                stopifnot(length(which(directions==1)) > 0)

                d <- .adjacentUD(x, cells, directions, include)

                directions <- sum(directions==1, na.rm=TRUE)
                mat <- TRUE

        } else if (directions==4) {
                if (include) {
                        d <- c(xy[,1], xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2])
                } else {
                        d <- c(xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2])
                }

        } else if (directions==8) {
                if (include) {
                        d <- c(xy[,1], rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1],
                                 xy[,2], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2])
                } else {
                        d <- c(rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1],
                                rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2])
                }
        } else if (directions==16) {
                r2 <- r * 2
                if (include) {
                        d <- c(xy[,1], rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2),
                                rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5),
                                xy[,1], xy[,1], 

                                xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2),
                                rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2),
                                xy[,2]+r[2], xy[,2]-r[2])
                } else {
                        d <- c(rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2),
                                rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5),
                                xy[,1], xy[,1], 

                                rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2),
                                rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2),
                                xy[,2]+r[2], xy[,2]-r[2])
                }                                       

        } else if (directions=='bishop') {
                if (include) {
                        d <- c(xy[,1], rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2))
                } else {
                        d <- c(rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2))            
                }
                directions <- 4 # to make pairs

        } else {
                stop('directions should be one of: 4, 8, 16, bishop, or a matrix')
        }
        if (include) directions <- directions + 1

        d <- matrix(d, ncol=2)
        if (.isGlobalLonLat(x)) {
                # normalize longitude to -180..180
                d[,1] <- (d[,1] + 180) %% 360 - 180
        }

        if (pairs) {
                if (mat) {
                        cell <- rep(cells, each=directions)             
                } else {
                        cell <- rep(cells, directions)
                }

                if (id) {
                        if (mat) {
                                ID <- rep(1:length(cells), each=directions)
                        } else {
                                ID <- rep(1:length(cells), directions)
                        }
                        d <- na.omit(cbind(ID, cell, cellFromXY(x, d)))
                        attr(d, 'na.action') <- NULL
                        colnames(d) <- c('id', 'from', 'to')
                        if (! is.null(target)) {
                                d <- d[d[,3] %in% target, ]
                        }

                } else {
                        d <- na.omit(cbind(cell, cellFromXY(x, d)))
                        attr(d, 'na.action') <- NULL
                        colnames(d) <- c('from', 'to')
                        if (! is.null(target)) {
                                d <- d[d[,2] %in% target, ]
                        }
                }
                if (sorted) {
                        d <- d[order(d[,1], d[,2]),]
                }
        } else {
                d <- as.vector(unique(na.omit(cellFromXY(x, d))))
                if (! is.null(target)) {
                        d <- intersect(d, target)
                }
                if (sorted) {
                        d <- sort(d)
                }
        }
        d
}

6 aggregate_3d.R

# Author: Robert J. Hijmans
# Date : July 2010
# Version 1.0
# Licence GPL v3
# October 2012: Major overhaul (including C interface)
# November 2012: fixed bug with expand=F
# June 2014: support for aggregation over z (layers) in addition to x and y
setMethod('aggregate', signature(x='Raster'), 
function(x, fact=2, fun='mean', expand=TRUE, na.rm=TRUE, filename=, ...)  {
        doC <- list(...)$doC
        if (is.null(doC)) {
                doC <- TRUE
        }
        nl <- nlayers(x)
        fact <- round(fact)
        lf <- length(fact)
        if (lf == 1) {
                fact <- c(fact, fact, 1)
        } else if (lf == 2) {
                fact <- c(fact, 1)
        } else if (lf > 3) {
                stop('fact should have length 1, 2, or 3')
        }
        if (nl < 2) {
                fact[3] <- 1
        }
        if (any(fact < 1)) {
                stop('fact should be > 0')
        }
        if (! any(fact > 1)) {
                stop('fact should be > 1')
        }
        xfact <- fact[1]
        yfact <- fact[2]
        zfact <- fact[3]

        ncx <- ncol(x)
        nrx <- nrow(x)
        if (xfact > ncx) {
                warning('aggregation factor is larger than the number of columns') 
                xfact <- ncx
        }
        if (yfact > nrx) {
                warning('aggregation factor is larger than the number of rows')
                yfact <- nrx
        }
        if (zfact > nl) {
                warning('aggregation factor is larger than the number of layers')
                zfact <- nl
        }
        addlyrs <- 0
        if (expand) {
                rsteps <- as.integer(ceiling(nrx/yfact))
                csteps <- as.integer(ceiling(ncx/xfact))
                lsteps <- as.integer(ceiling(nl/zfact))

                lastcol <- ncx
                lastrow <- nrx
                lastlyr <- lsteps * zfact
                if (lastlyr > nl ) {
                        addlyrs <- lastlyr - nl
                }
                lyrs <- 1:nl

                #addcols <- csteps * xfact - ncx
                #addrows <- rsteps * yfact - nrx
        } else  {
                rsteps <- as.integer(floor(nrx/yfact))
                csteps <- as.integer(floor(ncx/xfact))
                lsteps <- as.integer(floor(nl/zfact))

                lastcol <- min(csteps * xfact, ncx)
                lastrow <- min(rsteps * yfact, nrx)
                lastlyr <- min(lsteps * zfact, nl)

                lyrs <- 1:lastlyr
        }

        ymn <- ymax(x) - rsteps * yfact * yres(x)
        xmx <- xmin(x) + csteps * xfact * xres(x)

        if (lsteps > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)                
        }
        extent(out) <- extent(xmin(x), xmx, ymn, ymax(x))
        dim(out) <- c(rsteps, csteps, lsteps) 
        ncout <- ncol(out)
        if (zfact == 1) {
                names(out) <- names(x)
        }


        if (! hasValues(x) ) {  
                return(out) 
        }       
        fun <- .makeTextFun(fun)
        if (class(fun) == 'character') { 
                op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
        } else {
                op <- NA
        }

        if (zfact > 1) {
                xyzfact <- xfact*yfact*zfact
                dims <- as.integer(c(lastrow, lastcol, nl+addlyrs, xfact, yfact, zfact))
                if ( canProcessInMemory(x)) {
                        v <- getValuesBlock(x, 1, lastrow, 1, lastcol, lyrs)
                        if (addlyrs > 0) {
                                add <- matrix(NA, nrow=nrow(v), ncol=addlyrs)
                                v <- cbind(v, add)
                        }
                        v <- .Call(aggregate_get, as.double(v), as.integer(dims), PACKAGE='raster')
                        v <- matrix(v, nrow=xyzfact)
                        v <- apply(v, 2, fun, na.rm=na.rm)
                        out <- setValues(out, v)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)
                } else {
                        xx <- brick(x, values=FALSE)
                        if (!expand) {
                                nrow(xx) <- (nrow(x) %/% yfact) * yfact
                        }               
                        tr <- blockSize(xx, minrows=yfact)
                        st <- round(tr$nrows[1] / yfact) * yfact
                        tr$n <- ceiling(lastrow / st)
                        tr$row <- c(1, cumsum(rep(st, tr$n-1))+1)
                        tr$nrows <- rep(st, tr$n)
                        tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact)))
                        tr$nrows[tr$n] <-  nrow(xx) - tr$row[tr$n] + 1
                        tr$outrows <- ceiling(tr$nrows/yfact)

                        pb <- pbCreate(tr$n, label='aggregate', ...)
                        x <- readStart(x, ...)  
                        out <- writeStart(out, filename=filename, ...)
                        for (i in 1:tr$n) {
                                dims[1] <- as.integer(tr$nrows[i])
                                vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, lyrs)
                                if (addlyrs > 0) {
                                        add <- rep(NA, nrow(vals)*addlyrs)
                                        vals <- c(vals, add)
                                }
                                vals <- .Call(aggregate_get, as.double(vals), as.integer(dims), PACKAGE='raster')
                                vals <- matrix(vals, nrow=xyzfact)
                                vals <- apply(vals, 2, fun, na.rm=na.rm)
                                out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i])
                                pbStep(pb, i) 
                        }
                        pbClose(pb)
                        out <- writeStop(out)
                        x <- readStop(x)
                        return(out)     
                }
        }

        if (!is.na(op) & doC) {

                if ( canProcessInMemory(x)) {

                        dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
                        x <- getValuesBlock(x, 1, lastrow, 1, lastcol)
                        out <- setValues(out, .Call(aggregate, as.double(x), op, as.integer(na.rm), dims, PACKAGE='raster'))
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {

                        xx <- brick(x, values=FALSE)
                        if (!expand) {
                                nrow(xx) <- (nrow(x) %/% yfact) * yfact
                        }               
                        tr <- blockSize(xx, minrows=yfact)
                        st <- round(tr$nrows[1] / yfact) * yfact
                        tr$n <- ceiling(lastrow / st)
                        tr$row <- c(1, cumsum(rep(st, tr$n-1))+1)
                        tr$nrows <- rep(st, tr$n)
                        tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact)))
                        tr$nrows[tr$n] <-  nrow(xx) - tr$row[tr$n] + 1
                        tr$outrows <- ceiling(tr$nrows/yfact)

                        pb <- pbCreate(tr$n, label='aggregate', ...)
                        x <- readStart(x, ...)  
                        dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
                        out <- writeStart(out, filename=filename, ...)
                        if (inherits(out, 'RasterBrick')) {
                                for (i in 1:tr$n) {
                                        dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
                                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
                                        vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster')
                                        out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i])
                                        pbStep(pb, i) 
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
                                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
                                        vals <- .Call(aggregate, as.double(vals), op,   as.integer(na.rm), dims, PACKAGE='raster')
                                        out <- writeValues(out, vals, tr$write[i])
                                        pbStep(pb, i) 
                                }
                        }
                        pbClose(pb)
                        out <- writeStop(out)
                        x <- readStop(x)
                        return(out)     
                }
        }

 # else not implemented in C  

        if (nl < 2) {   
                if (class(fun) == 'character') { 
                        rowcalc <- TRUE 
                        fun <- .getColFun(fun)
                } else { 
                        rowcalc <- FALSE 
                }

                if ( canProcessInMemory(x)) {
                        if (expand) {
                                m <- ceiling(nrx / yfact)
                        } else {
                                m <- floor(nrx / yfact)
                        }
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
                        vend <- 0
                        vvstart <- 1

                        if (expand) {
                                vals <- getValues(x)
                                yf <- nrx %% yfact
                        } else {
                                vals <- getValuesBlock(x, 1, lastrow, 1, lastcol)
                                yf <- 0
                        }
                        for (j in 1:m) {
                                if (j == m & yf > 0) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yf)
                                        mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
                                        temp <- matrix(nrow=yf*xfact, ncol=csteps)
                                        temp[1:length(mv)] <- mv
                                        cols <- 1:(csteps) + (m-1) * csteps
                                        vv[1:nrow(temp), cols] <- temp

                                } else {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                        }
                        if (rowcalc) {
                                vals <- fun(vv, na.rm=na.rm )
                        } else {
                                vals <- apply(vv, 2, fun, na.rm=na.rm )
                        }
                        out <- setValues(out, as.vector(vals))
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {

                        out <- writeStart(out, filename=filename, ...)


                        tr <- blockSize(x, minrows=yfact)
                        st <- round(tr$nrows[1] / yfact) * yfact
                        tr$n <- ceiling(lastrow / st)
                        tr$row <- c(1, cumsum(rep(st, tr$n-1))+1)
                        tr$nrows <- rep(st, tr$n)
                        tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact)))
                        dif <- sum(tr$nrows) - nrow(x)
                        if (dif > 0) {
                                if (expand) {
                                        tr$nrows[tr$n] <-  tr$nrows[tr$n] - dif
                                } else {
                                        dif <- dif %/% xfact
                                        if (dif > 0) {
                                                tr$nrows[tr$n] <- dif * xfact
                                        } else {
                                                tr$n <- tr$n - 1
                                        }
                                }
                        }

                        pb <- pbCreate(tr$n, label='aggregate', ...)
                        x <- readStart(x, ...)  
                        m <- tr$nrows[1] / yfact
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)

                        w <- getOption('warn')
                        on.exit(options('warn' = w))
                        options('warn'=-1) 

                        for (i in 1:(tr$n-1)) {
                                vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)           
                                vend <- 0
                                vvstart <- 1
                                for (j in 1:m) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)                     
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                                if (rowcalc) {
                                        vals <- fun(vv, na.rm=na.rm )
                                } else {
                                        vals <- apply(vv, 2, fun, na.rm=na.rm )
                                }
                                out <- writeValues(out, vals, tr$write[i])
                                pbStep(pb, i) 
                        } 
        #       if (i==tr$n) { 
                        i <- tr$n
                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)           
                        m <- ceiling(tr$nrows[i] / yfact)
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
                        vend <- 0
                        vvstart <- 1
                        yf <- tr$nrows[i] %% yfact
                        for (j in 1:m) {
                                if (j == m & yf > 0) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yf)
                                        mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
                                        temp <- matrix(nrow=yf*xfact, ncol=csteps)
                                        temp[1:length(mv)] <- mv
                                        cols <- 1:(csteps) + (m-1) * csteps
                                        vv[1:nrow(temp), cols] <- temp

                                } else {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                        }
                        if (rowcalc) {
                                vals <- fun(vv, na.rm=na.rm )
                        } else {
                                vals <- apply(vv, 2, fun, na.rm=na.rm )
                        }
                        pbStep(pb, i) 
                        out <- writeValues(out, vals, tr$write[i])
                        pbClose(pb)
                        x <- readStop(x)        
                        out <- writeStop(out)
                        return(out)
                }

        } else { # nlayers > 1

                if (canProcessInMemory(x, nlayers(x)+2)) {

                        if (class(fun) == 'character') { 
                                op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
                        }
                        if (!is.na(op) & doC) {
                                dim <- c(dim(x), dim(out)[1:2], xfact, yfact)
                                v  <- .Call(aggregate, 
                                                as.double(getValues(x)), op, as.integer(na.rm), 
                                                as.integer(dim), PACKAGE='raster')

                                out <- setValues(out, matrix(v, ncol=dim[3]))           
                                return(out)     
                        }

                        xx <- raster(x)         
                        x <- getValues(x)
                        cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx))
                        rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)]
                        cells <- cellFromRowCol(xx, rows, cols)

                        x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1]
                        rm(cells)

                        x <- setValues(out, x)
                        if (filename != ) {
                                x <- writeRaster(x, filename=filename, ...)
                        }
                        return(x)
                } else  { 

                        cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact)
                        rows <- rep(1, each=(ncol(x) * yfact))

                        out <- writeStart(out, filename=filename, ...)
                        x <- readStart(x, ...)  

                        cells <- cellFromRowCol(x, rows, cols)
                        nrows <- yfact
                        w <- getOption('warn')
                        on.exit(options('warn' = w))
                        options('warn'=-1) 

                        pb <- pbCreate(rsteps, label='aggregate', ...)
                        for (r in 1:rsteps) {
                                startrow <- 1 + (r - 1) * yfact
                                if ( r==rsteps) {
                                        endrow <- min(nrow(x), startrow + yfact - 1)
                                        nrows <- endrow - startrow + 1
                                        theserows <- (startrow * rows)[1:(ncol(x)*nrows)]
                                        cols <- cols[1:(ncol(x)*nrows)]
                                        cells <- cellFromRowCol(x, theserows, cols)
                                }       
                                vals <- getValues(x, startrow, nrows)
                                vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1]

                                out <- writeValues(out, vals, r)
                                pbStep(pb, r) 
                        } 
                        pbClose(pb)
                        out <- writeStop(out)
                        x <- readStop(x)        
                        return(out)
                }       
        }
}
)
#library(raster)
#r <- raster(nc=9, nr=9)
#r <- raster()
#r[] = 1:ncell(r)
#.aggtest(r, 5, 'min', doC=T)
#aggregate(s, c(2,1,3), 'min', expand=F)

7 aggregate_old.R

# Author: Robert J. Hijmans
# Date : July 2010
# Version 1.0
# Licence GPL v3
.aggregate_old <- function(x, fact=2, fun=mean, expand=TRUE, na.rm=TRUE, filename=, ...)  {
        if (length(fact)==1) {
                fact <- as.integer(round(fact))
                if (fact < 2) { stop('fact should be > 1') }
                xfact <- yfact <- fact
        } else if (length(fact)==2) {
                xfact <- as.integer(round(fact[[1]]))
                yfact <- as.integer(round(fact[[2]]))
                if (xfact < 2) { stop('fact[[1]] should be > 1') } 
                if (yfact < 2) { stop('fact[[2]] should be > 1') }
        } else {
                stop('length(fact) should be 1 or 2')
        }
        if (xfact > ncol(x)) {
                warning('aggregation factor is larger than the number of columns') 
                xfact <- ncol(x)
        }
        if (yfact > nrow(x)) {
                warning('aggregation factor is larger than the number of rows')
                yfact <- nrow(x)
        }
        if (expand) {
                rsteps <- as.integer(ceiling(nrow(x)/yfact))
                csteps <- as.integer(ceiling(ncol(x)/xfact))
                lastcol <- x@ncols
                lastrow <- x@nrows
        } else  {
                rsteps <- as.integer(floor(nrow(x)/yfact))
                csteps <- as.integer(floor(ncol(x)/xfact))
                lastcol <- min(csteps * xfact, x@ncols)
                lastrow <- min(rsteps * yfact, x@nrows)
        }

        ymn <- ymax(x) - rsteps * yfact * yres(x)
        xmx <- xmin(x) + csteps * xfact * xres(x)

        nl <- nlayers(x)
        if (nl > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)                
        }
        extent(out) <- extent(xmin(x), xmx, ymn, ymax(x))
        dim(out) <- c(rsteps, csteps) 
        names(out) <- names(x)
        if (! hasValues(x) ) {  return(out) }   

        if (nl < 2) {   
                fun <- .makeTextFun(fun)
                if (class(fun) == 'character') { 
                        rowcalc <- TRUE 
                        fun <- .getRowFun(fun)
                } else { 
                        rowcalc <- FALSE 
                }
                if (! canProcessInMemory(x)) {
                        if (filename == '') { 
                                filename <- rasterTmpFile() 
                        }
                }

                if (filename == '') {
                        v <- matrix(NA, ncol=nrow(out), nrow=ncol(out))
                } else {
                        out <- writeStart(out, filename=filename, ...)
                }

                pb <- pbCreate(rsteps, ...)

                        #vv <- matrix(ncol= csteps * yfact, nrow=rsteps * xfact)
                vv <- matrix(nrow= yfact * xfact, ncol=csteps)
                w <- getOption('warn')
                on.exit(options('warn' = w))
                options('warn'=-1) 
                for (r in 1:rsteps) {

                        startrow <- 1 + (r - 1) * yfact
                        vals <- getValuesBlock(x, startrow, yfact, 1, lastcol)

                        if (r==rsteps) { 
                                endrow <- min(x@nrows, (startrow + yfact - 1))
                                nrows <- endrow - startrow + 1
                                vals <- matrix(vals, nrow=nrows, byrow=TRUE )
                                vv[] <- NA 
                                vvv <- vv[1:(nrows*xfact), ,drop=FALSE]
                                vvv[1:length(vals)] <- vals
                                vv[1:nrow(vvv),] <- vvv

                        } else {
                                vals <- matrix(vals, nrow=yfact, byrow=TRUE )
                                vv[1:length(vals)] = vals
                        }

                        if (rowcalc) {
                                vals <- fun(t(vv), na.rm=na.rm )
                        } else {
                                vals <- apply(vv, 2, fun, na.rm=na.rm )
                        }
                        if (filename == ) {
                                v[, r] <- vals
                        } else {
                                out <- writeValues(out, vals, r)
                        }
                        pbStep(pb, r) 
                } 

                pbClose(pb)
                if (filename == ) { 
                        values(out) <- as.vector(v)
                } else {
                        out <- writeStop(out)
                }
                return(out)

        } else { # nlayers > 1


                if (canProcessInMemory(x, nlayers(x)+2)) {

                        xx <- raster(x)         
                        x <- getValues(x)
                        cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx))
                        rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)]
                        cells <- cellFromRowCol(xx, rows, cols)

                        x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1]
                        rm(cells)

                        x <- setValues(out, x)
                        if (filename != ) {
                                x <- writeRaster(x, filename=filename, ...)
                        }
                        return(x)
                } else  { 

                        cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact)
                        rows <- rep(1, each=(ncol(x) * yfact))
                        cells <- cellFromRowCol(x, rows, cols)
                        nrows <- yfact
                        w <- getOption('warn')
                        on.exit(options('warn' = w))
                        options('warn'=-1) 

                        out <- writeStart(out, filename=filename, ...)
                        pb <- pbCreate(rsteps, ...)
                        for (r in 1:rsteps) {
                                startrow <- 1 + (r - 1) * yfact
                                if ( r==rsteps) {
                                        endrow <- min(nrow(x), startrow + yfact - 1)
                                        nrows <- endrow - startrow + 1
                                        theserows <- (startrow * rows)[1:(ncol(x)*nrows)]
                                        cols <- cols[1:(ncol(x)*nrows)]
                                        cells <- cellFromRowCol(x, theserows, cols)
                                }       
                                vals <- getValues(x, startrow, nrows)
                                vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1]

                                out <- writeValues(out, vals, r)
                                pbStep(pb, r) 
                        } 
                        pbClose(pb)
                        out <- writeStop(out)
                        return(out)
                }

        }
}

8 aggregate.R

# Author: Robert J. Hijmans
# Date : July 2010
# Version 1.0
# Licence GPL v3
# October 2012: Major overhaul (including C interface)
# November 2012: fixed bug with expand=F
setMethod('aggregate', signature(x='Raster'), 
function(x, fact=2, fun='mean', expand=TRUE, na.rm=TRUE, filename=, ...)  {
        doC <- list(...)$doC
        if (is.null(doC)) {
                doC <- TRUE
        }
        fact <- rep(as.integer(round(fact)), length.out=2)
        xfact <- fact[1]
        yfact <- fact[2]
        if (xfact < 1 | yfact < 1) { stop('fact should be > 0') } 
        if (xfact < 2 & yfact < 2) { stop('fact[1] or fact[2] should be > 1') } 

        if (xfact > ncol(x)) {
                warning('aggregation factor is larger than the number of columns') 
                xfact <- ncol(x)
        }
        if (yfact > nrow(x)) {
                warning('aggregation factor is larger than the number of rows')
                yfact <- nrow(x)
        }
        ncx <- ncol(x)
        nrx <- nrow(x)
        if (expand) {
                rsteps <- as.integer(ceiling(nrx/yfact))
                csteps <- as.integer(ceiling(ncx/xfact))
                lastcol <- x@ncols
                lastrow <- x@nrows
                #addcols <- csteps * xfact - ncx
                #addrows <- rsteps * yfact - nrx
        } else  {
                rsteps <- as.integer(floor(nrx/yfact))
                csteps <- as.integer(floor(ncx/xfact))
                lastcol <- min(csteps * xfact, x@ncols)
                lastrow <- min(rsteps * yfact, x@nrows)
        }


        ymn <- ymax(x) - rsteps * yfact * yres(x)
        xmx <- xmin(x) + csteps * xfact * xres(x)

        nl <- nlayers(x)
        if (nl > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)                
        }
        extent(out) <- extent(xmin(x), xmx, ymn, ymax(x))
        dim(out) <- c(rsteps, csteps) 
        names(out) <- names(x)
        ncout <- ncol(out)
        if (! hasValues(x) ) {  return(out) }   
        fun <- .makeTextFun(fun)
        if (class(fun) == 'character') { 
                op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
        } else {
                op <- NA
        }

        if (!is.na(op) & doC) {

                if ( canProcessInMemory(x)) {

                        dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
                        x <- getValuesBlock(x, 1, lastrow, 1, lastcol)
                        out <- setValues(out, .Call(aggregate, as.double(x), op, as.integer(na.rm), dims, PACKAGE='raster'))
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {

                        xx <- brick(x, values=FALSE)
                        if (!expand) {
                                xx <- brick(x, values=FALSE)
                                nrow(xx) <- (nrow(x) %/% yfact) * yfact
                        }               
                        tr <- blockSize(xx, minrows=yfact)
                        st <- round(tr$nrows[1] / yfact) * yfact
                        tr$n <- ceiling(lastrow / st)
                        tr$row <- c(1, cumsum(rep(st, tr$n-1))+1)
                        tr$nrows <- rep(st, tr$n)
                        tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact)))
                        tr$nrows[tr$n] <-  nrow(xx) - tr$row[tr$n] + 1
                        tr$outrows <- ceiling(tr$nrows/yfact)

                        pb <- pbCreate(tr$n, label='aggregate', ...)
                        x <- readStart(x, ...)  
                        dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
                        out <- writeStart(out, filename=filename, ...)
                        if (inherits(out, 'RasterBrick')) {
                                for (i in 1:tr$n) {
                                        dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
                                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
                                        vals <- .Call(aggregate, as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster')
                                        out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i])
                                        pbStep(pb, i) 
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
                                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
                                        vals <- .Call(aggregate, as.double(vals), op,   as.integer(na.rm), dims, PACKAGE='raster')
                                        out <- writeValues(out, vals, tr$write[i])
                                        pbStep(pb, i) 
                                }
                        }
                        pbClose(pb)
                        out <- writeStop(out)
                        x <- readStop(x)
                        return(out)     
                }
        }

 # else not implemented in C  

        if (nl < 2) {   
                if (class(fun) == 'character') { 
                        rowcalc <- TRUE 
                        fun <- .getColFun(fun)
                } else { 
                        rowcalc <- FALSE 
                }

                if ( canProcessInMemory(x)) {
                        if (expand) {
                                m <- ceiling(nrx / yfact)
                        } else {
                                m <- floor(nrx / yfact)
                        }
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
                        vend <- 0
                        vvstart <- 1

                        if (expand) {
                                vals <- getValues(x)
                                yf <- nrx %% yfact
                        } else {
                                vals <- getValuesBlock(x, 1, lastrow, 1, lastcol)
                                yf <- 0
                        }
                        for (j in 1:m) {
                                if (j == m & yf > 0) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yf)
                                        mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
                                        temp <- matrix(nrow=yf*xfact, ncol=csteps)
                                        temp[1:length(mv)] <- mv
                                        cols <- 1:(csteps) + (m-1) * csteps
                                        vv[1:nrow(temp), cols] <- temp

                                } else {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                        }
                        if (rowcalc) {
                                vals <- fun(vv, na.rm=na.rm )
                        } else {
                                vals <- apply(vv, 2, fun, na.rm=na.rm )
                        }
                        out <- setValues(out, as.vector(vals))
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {

                        out <- writeStart(out, filename=filename, ...)


                        tr <- blockSize(x, minrows=yfact)
                        st <- round(tr$nrows[1] / yfact) * yfact
                        tr$n <- ceiling(lastrow / st)
                        tr$row <- c(1, cumsum(rep(st, tr$n-1))+1)
                        tr$nrows <- rep(st, tr$n)
                        tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact)))
                        dif <- sum(tr$nrows) - nrow(x)
                        if (dif > 0) {
                                if (expand) {
                                        tr$nrows[tr$n] <-  tr$nrows[tr$n] - dif
                                } else {
                                        dif <- dif %/% xfact
                                        if (dif > 0) {
                                                tr$nrows[tr$n] <- dif * xfact
                                        } else {
                                                tr$n <- tr$n - 1
                                        }
                                }
                        }

                        pb <- pbCreate(tr$n, label='aggregate', ...)
                        x <- readStart(x, ...)  
                        m <- tr$nrows[1] / yfact
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)

                        w <- getOption('warn')
                        on.exit(options('warn' = w))
                        options('warn'=-1) 

                        for (i in 1:(tr$n-1)) {
                                vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)           
                                vend <- 0
                                vvstart <- 1
                                for (j in 1:m) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)                     
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                                if (rowcalc) {
                                        vals <- fun(vv, na.rm=na.rm )
                                } else {
                                        vals <- apply(vv, 2, fun, na.rm=na.rm )
                                }
                                out <- writeValues(out, vals, tr$write[i])
                                pbStep(pb, i) 
                        } 
        #       if (i==tr$n) { 
                        i <- tr$n
                        vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)           
                        m <- ceiling(tr$nrows[i] / yfact)
                        vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
                        vend <- 0
                        vvstart <- 1
                        yf <- tr$nrows[i] %% yfact
                        for (j in 1:m) {
                                if (j == m & yf > 0) {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yf)
                                        mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
                                        temp <- matrix(nrow=yf*xfact, ncol=csteps)
                                        temp[1:length(mv)] <- mv
                                        cols <- 1:(csteps) + (m-1) * csteps
                                        vv[1:nrow(temp), cols] <- temp

                                } else {
                                        vstart <- vend + 1
                                        vend <- vend + (lastcol * yfact)
                                        mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )

                                        vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
                                        vvstart <- vvstart + ncout*nrow(vv)
                                }
                        }
                        if (rowcalc) {
                                vals <- fun(vv, na.rm=na.rm )
                        } else {
                                vals <- apply(vv, 2, fun, na.rm=na.rm )
                        }
                        pbStep(pb, i) 
                        out <- writeValues(out, vals, tr$write[i])
                        pbClose(pb)
                        x <- readStop(x)        
                        out <- writeStop(out)
                        return(out)
                }

        } else { # nlayers > 1

                if (canProcessInMemory(x, nlayers(x)+2)) {

                        if (class(fun) == 'character') { 
                                op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
                        }
                        if (!is.na(op) & doC) {
                                dim <- c(dim(x), dim(out)[1:2], xfact, yfact)
                                v  <- .Call(aggregate, 
                                                as.double(getValues(x)), op, as.integer(na.rm), 
                                                as.integer(dim), PACKAGE='raster')

                                out <- setValues(out, matrix(v, ncol=dim[3]))           
                                return(out)     
                        }

                        xx <- raster(x)         
                        x <- getValues(x)
                        cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx))
                        rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)]
                        cells <- cellFromRowCol(xx, rows, cols)

                        x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1]
                        rm(cells)

                        x <- setValues(out, x)
                        if (filename != ) {
                                x <- writeRaster(x, filename=filename, ...)
                        }
                        return(x)
                } else  { 

                        cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact)
                        rows <- rep(1, each=(ncol(x) * yfact))

                        out <- writeStart(out, filename=filename, ...)
                        x <- readStart(x, ...)  

                        cells <- cellFromRowCol(x, rows, cols)
                        nrows <- yfact
                        w <- getOption('warn')
                        on.exit(options('warn' = w))
                        options('warn'=-1) 

                        pb <- pbCreate(rsteps, label='aggregate', ...)
                        for (r in 1:rsteps) {
                                startrow <- 1 + (r - 1) * yfact
                                if ( r==rsteps) {
                                        endrow <- min(nrow(x), startrow + yfact - 1)
                                        nrows <- endrow - startrow + 1
                                        theserows <- (startrow * rows)[1:(ncol(x)*nrows)]
                                        cols <- cols[1:(ncol(x)*nrows)]
                                        cells <- cellFromRowCol(x, theserows, cols)
                                }       
                                vals <- getValues(x, startrow, nrows)
                                vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1]

                                out <- writeValues(out, vals, r)
                                pbStep(pb, r) 
                        } 
                        pbClose(pb)
                        out <- writeStop(out)
                        x <- readStop(x)        
                        return(out)
                }       
        }
}
)
#library(raster)
#r <- raster(nc=9, nr=9)
#r <- raster()
#r[] = 1:ncell(r)
#.aggtest(r, 5, 'min', doC=T)

9 aggregate_sp.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
setMethod('aggregate', signature(x='SpatialPolygons'), 
function(x, vars=NULL, sums=NULL, dissolve=TRUE, ...) {
        if (dissolve) {
                stopifnot(require(rgeos))
        }

        if (! .hasSlot(x, 'data') ) {
                hd <- FALSE
                if (!is.null(vars)) {
                        if (length(vars) == length(x@polygons)) {
                                x <- SpatialPolygonsDataFrame(x, data=data.frame(ID=vars))
                                vars <- 1
                        }
                }
        } else {
                hd <- TRUE
        }

        if (isTRUE(is.null(vars))) {
                if (dissolve) {
                        if (version_GEOS() < 3.3.0) {
                                x <- gUnionCascaded(x)
                        } else {
                                x <- rgeos::gUnaryUnion(x)
                        }
                } else {
                        p <- list()
                        for (i in 1:length(x)) {
                                nsubobs <- length(x@polygons[[i]]@Polygons)
                                p <- c(p, lapply(1:nsubobs, function(j) x@polygons[[i]]@Polygons[[j]]))
                        }
                        x <- SpatialPolygons(list(Polygons(p, '1')), proj4string=x@proj4string)
                }
                #if (hd) {
                #       x <- SpatialPolygonsDataFrame(x, data=data.frame(ID=1))
                #}
                return(x)

        } else {
                getVars <- function(v, cn) {
                        vl <- length(v)
                        v <- unique(v)
                        if (is.numeric(v)) {
                                v <- round(v)
                                v <- v[v>0 & v <= ncol(x@data)]
                                if (length(v) < 1) {
                                        stop('invalid column numbers')
                                }
                        } else if (is.character(v)) {
                                v <- v[v %in% cn]
                                if (length(v) < 1) {
                                        stop('invalid column names')
                                }
                        }
                        v
                }

                dat <- x@data
                cn <- colnames(dat)
                v <- getVars(vars, cn)

                dat <- dat[,v, drop=FALSE]
                crs <- x@proj4string
                dc <- apply(dat, 1, function(y) paste(as.character(y), collapse='_'))
                dc <- data.frame(oid=1:length(dc), v=as.integer(as.factor(dc)))
                id <- dc[!duplicated(dc$v), ,drop=FALSE]
                id <- id[order(id$v), ]
                dat <- dat[id[,1], ,drop=FALSE]
                if (!is.null(sums)) {
                        out <- list()
                        for (i in 1:length(sums)) {
                                if (length(sums[[i]]) != 2) {
                                        stop('argument s most of be list in which each element is a list of two (fun + varnames)')
                                }
                                fun = sums[[i]][[1]]
                                if (!is.function(fun)) {
                                        if (is.character(fun)) {
                                                if (tolower(fun[1]) == 'first') {
                                                        fun <- function(x) x[1]
                                                } else if  (tolower(fun[1]) == 'last') {
                                                        fun <- function(x) x[length(x)]
                                                } 
                                        }
                                }
                                v <- getVars(sums[[i]][[2]], cn)
                                ag <- aggregate(x@data[,v,drop=FALSE], by=list(dc$v), FUN=fun) 
                                out[[i]] <- ag[,-1,drop=FALSE]
                        }
                        out <- do.call(cbind, out)
                        dat <- cbind(dat, out)
                }

                if (hd) {
                        x <- as(x, 'SpatialPolygons')
                }
                if (dissolve) {
                        if (version_GEOS0() < 3.3.0) {
                                x <- lapply(1:nrow(id), function(y) spChFIDs(gUnionCascaded(x[dc[dc$v==y,1],]), as.character(y)))
                        } else {
                                x <- lapply(1:nrow(id), function(y) spChFIDs(rgeos::gUnaryUnion(x[dc[dc$v==y,1],]), as.character(y)))
                        }       
                } else {
                        x <- lapply(1:nrow(id), function(y) spChFIDs(aggregate(x[dc[dc$v==y,1],], dissolve=FALSE), as.character(y)))
                }

                x <- do.call(rbind, x)
                x@proj4string <- crs
                rownames(dat) <- NULL
                SpatialPolygonsDataFrame(x, dat, FALSE)
        }
}
)

10 alignExtent.R

# Author: Robert J. Hijmans
# contact: r.hijmans@gmail.com
# Date : November 2010
# Version 1.0
# Licence GPL v3
alignExtent <- function(extent, object, snap='near') {
        snap <- tolower(snap)
        stopifnot(snap %in% c('near', 'in', 'out'))

        extent <- extent(extent)
        if (!inherits(object, 'BasicRaster')) { stop('object should inherit from BasicRaster') }
        res <- res(object)
        orig <- origin(object)

# snap points to pixel boundaries
        if (snap == 'near') {
                xmn <- round((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1]
                xmx <- round((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1]
                ymn <- round((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2]
                ymx <- round((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2]
        } else if (snap == 'out') {
                xmn <- floor((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1]
                xmx <- ceiling((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1]
                ymn <- floor((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2]
                ymx <- ceiling((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2]
        } else if (snap == 'in') {
                xmn <- ceiling((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1]
                xmx <- floor((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1]
                ymn <- ceiling((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2]
                ymx <- floor((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2]
        }

        if (xmn == xmx) {
                if (xmn < extent@xmin) {
                        xmx <- xmx + res[1]
                } else {
                        xmn <- xmn - res[1]             
                }
        }
        if (ymn == ymx) {
                if (ymn < extent@ymin) {
                        ymx <- ymx + res[2]
                } else {
                        ymn <- ymn - res[2]             
                }
        }
        extent(xmn, xmx, ymn, ymx)
}
.Old.alignExtent <- function(extent, object) {
        object <- raster(object)
        oldext <- extent(object)
        e <- extent(extent)
        e@xmin <- min(e@xmin, oldext@xmin)
        e@xmax <- max(e@xmax, oldext@xmax)
        e@ymin <- min(e@ymin, oldext@ymin)
        e@ymax <- max(e@ymax, oldext@ymax)


        col <- colFromX(object, e@xmin)
        mn <- xFromCol(object, col) - 0.5 * xres(object)
        mx <- xFromCol(object, col) + 0.5 * xres(object)
        if (abs(e@xmin - mn) > abs(e@xmin - mx)) { 
                e@xmin <- mx 
        } else { 
                e@xmin <- mn 
        }
        col <- colFromX(object, e@xmax)
        if (is.na(col))
        mn <- xFromCol(object, col) - 0.5 * xres(object)
        mx <- xFromCol(object, col) + 0.5 * xres(object)
        if (abs(e@xmax - mn) > abs(e@xmax - mx)) { 
                e@xmax <- mx 
        } else { 
                e@xmax <- mn 
        }

        row <- rowFromY(object, e@ymin)
        mn <- yFromRow(object, row) - 0.5 * yres(object)
        mx <- yFromRow(object, row) + 0.5 * yres(object)
        if (abs(e@ymin - mn) > abs(e@ymin - mx)) {
                e@ymin <- mx
        } else { 
                e@ymin <- mn 
        }
        row <- rowFromY(object, e@ymax)
        mn <- yFromRow(object, row) - 0.5 * yres(object)
        mx <- yFromRow(object, row) + 0.5 * yres(object)
        if (abs(e@ymax - mn) > abs(e@ymax - mx)) { 
                e@ymax <- mx 
        } else {
                e@ymax <- mn 
        }

        if ( e@ymin == e@ymax ) {
                if (oldext@ymax > e@ymax) {
                        e@ymax = e@ymax + yres(object)
                } 
                if (oldext@ymin < e@ymin) {
                        e@ymin = e@ymin - yres(object)          
                }
        }
        if ( e@xmin == e@xmax ) {
                if (oldext@xmax > e@xmax) {
                        e@xmax = e@xmax + xres(object)
                } 
                if (oldext@xmin < e@xmin) {
                        e@xmin = e@xmin - xres(object)          
                }
        }
        return(e)
}

11 animate.R

if (!isGeneric(animate)) {
        setGeneric(animate, function(x, ...)
                standardGeneric(animate))
}       
setMethod('animate', signature(x='RasterStackBrick'), 
function(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) {
        nl <- nlayers(x)
        if (missing(main)) {
                main <- getZ(x)
                if (is.null(main)) {
                        main <- names(x)
                }
        }
        x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE)

        if (missing(zlim)) {
                zlim <- c(min(minValue(x)), max(maxValue(x)))
        }

        i <- 1
        reps <- 0
    while (reps < n) {
        plot(x[[i]], main = main[i], zlim=zlim, maxpixels=Inf, ...)
        dev.flush()
        Sys.sleep(pause)
        i <- i + 1
        if (i > nl) {
            i <- 1
                        reps <- reps+1
                }
    }
}
)
#anim(st, tvals)

12 approxNA.R

# Author: Robert J. Hijmans
# Date : February 2012
# Version 1.0
# Licence GPL v3
if (!isGeneric(approxNA)) {
        setGeneric(approxNA, function(x, ...)
                standardGeneric(approxNA))
}       
setMethod('approxNA', signature(x='RasterStackBrick'), 
function(x, filename=, method=linear, yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) { 
        filename <- trim(filename)
        out <- brick(x, values=FALSE)
        nl <- nlayers(out)
        if (nl < 2) {
                warning('cannot interpolate with a single layer')
                return(x)
        }

        if (is.null(z)) {
                xout <- getZ(x)
                if (is.null(xout)) {
                        xout <- 1:nl
                } else if (length(xout)!= nl) {
                        stop('length of values returned by getZ(x) does not match the number of layers of x')
                }
        } else {
                if (length(z)!= nl) {
                        stop('length of z does not match the number of layers of x')
                }
                xout <- z               
        }

        ifelse((missing(yleft) & missing(yright)), ylr <- 0L, ifelse(missing(yleft), ylr <- 1L, ifelse(missing(yright), ylr <- 2L, ylr <- 3L)))

        if (canProcessInMemory(x)) {
                x <- getValues(x)
                s <- rowSums(is.na(x))
                if (isTRUE(NArule)) {
                        j <- s == (nl-1) # one non-NA only
                        if (length(j) > 0 ) {
                                x[j, ] <- apply(x[j, ], 1, max, na.rm=TRUE)
                        }
                }
                i <- s < (nl-1) # at least two
                if (length(i) > 0 ) {
                        if (ylr==0) {
                                x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y ))
                        } else if (ylr==1) {
                                x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y ))                     
                        } else if (ylr==2) {
                                x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y ))                                               
                        } else {
                                x[i,] <- t(apply(x[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y ))
                        }
                } else {
                        warning('no NA values to approximate')
                }
                x <- setValues(out, x)
                if (filename != '') {
                        x <- writeRaster(x, filename=filename, ...)
                }
                return(x)
        } 

        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='approxNA', ...)
        out <- writeStart(out, filename=filename, ...)
        for (j in 1:tr$n) {
                v <- getValues(x, row=tr$row[j], nrows=tr$nrows[j])
                s <- rowSums(is.na(v))
                if (isTRUE(NArule)) {
                        j <- s == (nl-1) # one non-NA only
                        if (length(j) > 0 ) {
                                v[j, ] <- apply(v[j, ], 1, max, na.rm=TRUE)
                        }
                }
                i <- (s < nl-1) # need at least two
                if (length(i) > 0 ) {
                        if (ylr==0) {
                                v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y ) )
                        } else if (ylr==1) {
                                v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y ) )
                        } else if (ylr==2) {
                                v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y ) )
                        } else {
                                v[i,] <- t( apply(v[i,], 1, function(x) approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y ) )
                        }
                }
                out <- writeValues(out, v, tr$row[j])
                pbStep(pb)
        }

        pbClose(pb)
        out <- writeStop(out)
        return(out)
}
)

13 area.R

# Author: Robert J. Hijmans
# Date : December 2009
# Version 0.9
# Licence GPL v3
.cellArea <- function(x, r=6378137) {
# currently not used
        dlonR2 <- xres(x) * (pi / 180) * r^2
        lat <- yFromRow(x, 1:nrow(x))
        lat <- cbind(lat, lat)
        dlat <- yres(x) 
        lat[,1] <- lat[,1] + 0.5 * dlat
        lat[,2] <- lat[,2] - 0.5 * dlat
        lat <- sin(lat * (pi / 180) )
        # for one column:
        abs(lat[,2] - lat[,1]) * dlonR2
}
if (!isGeneric(area)) {
        setGeneric(area, function(x, ...)
                standardGeneric(area))
}       
setMethod('area', signature(x='SpatialPolygons'), 
        function(x, ...) {
                if (couldBeLonLat(x)) {
                        warning('polygon area in square degrees is not very meaningful')
                }
                sapply(x@polygons, function(i) slot(i, 'area'))
        }
)       
setMethod('area', signature(x='RasterLayer'), 
        function(x, filename='', na.rm=FALSE, weights=FALSE, ...) {
                out <- raster(x)

                if (na.rm) {
                        if (! hasValues(x) ) {
                                na.rm <- FALSE
                                warning('x' has no values, ignoring 'na.rm=TRUE')
                                rm(x)
                        }
                } else {
                        rm(x)
                }       

                if (! couldBeLonLat(out)) {
                        warning('This function is only useful for Raster* objects with a longitude/latitude coordinates')
                        ar <- prod(res(out))
                        return( init(out, function(x) ar, filename=filename, ...) )
                }

                filename <- trim(filename)
                if (!canProcessInMemory(out, 3) & filename == '') {
                        filename <- rasterTmpFile()
                }

                if (filename == '') {
                        v <- matrix(NA, ncol=nrow(out), nrow=ncol(out))
                } else {
                        if (weights) {
                                outfname = filename
                                filename = rasterTmpFile()
                        }
                        out <- writeStart(out, filename=filename, ...)
                }
                dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE)
                y <- yFromRow(out, 1:nrow(out))
                #dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE)
                dx <- .haversine(0, y, xres(out), y)
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='area', ...)
                        for (i in 1:tr$n) {
                                r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1)
                                vv <- dx[r] * dy / 1000000
                                vv <- rep(vv, each=out@ncols)
                                if (na.rm) {
                                        a <- getValues(x, tr$row[i], tr$nrows[i])
                                        vv[is.na(a)] <- NA
                                }
                                if (filename == ) {
                                        v[,r] <- vv
                                } else {
                                        out <- writeValues(out, vv, tr$row[i])
                                }
                                pbStep(pb, i)
                        }
                pbClose(pb)

                if (filename == ) { 
                        v <- as.vector(v)
                        if (weights) {
                                v <- v / sum(v, na.rm=TRUE)
                        }
                        values(out) <- v
                } else {
                        out <- writeStop(out)   
                        if (weights) {
                                total <- cellStats(out, 'sum')
                                out <- calc(out, fun=function(x){x/total}, filename=outfname, ...)
                        }
                }

                return(out)
        }
)
setMethod('area', signature(x='RasterStackBrick'), 
        function(x, filename='', na.rm=FALSE, weights=FALSE, ...) {
                if (! na.rm) {
                        return( area(raster(x), filename=filename, na.rm=FALSE, weights=weights, ...) )
                }       

                out <- brick(x, values=FALSE)
                if (! couldBeLonLat(out)) {
                        stop('This function is only useful for Raster* objects with a longitude/latitude coordinates')
                }

                filename <- trim(filename)
                if (!canProcessInMemory(out) & filename == '') {
                        filename <- rasterTmpFile()
                }
                nl <- nlayers(out)

                if (filename == '') {
                        v <- matrix(NA, ncol=nl, nrow=ncell(out))
                } else {
                        if (weights) {
                                outfname = filename
                                filename = rasterTmpFile()
                        }
                        out <- writeStart(out, filename=filename, ...)
                }
                dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE)
                y <- yFromRow(out, 1:nrow(out))
                dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE)
                if (.doCluster() ) {
                        cl <- getCluster()
                        on.exit( returnCluster() )
                        nodes <- min(nrow(out), length(cl))     
                        cat( 'Using cluster with', nodes, 'nodes\n' )
                        flush.console()         

                        tr <- blockSize(out, minblocks=nodes)
                        pb <- pbCreate(tr$n, label='area', ...)
#                       clFun <- function(i, tr, dx, dy, out, nl) {
                        clFun <- function(i) {
                                r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1)
                                vv <- dx[r] * dy / 1000000
                                vv <- rep(vv, each=out@ncols)

                                vv <- matrix(rep(vv, times=nl), ncol=nl)
                                a <- getValues(x, tr$row[i], tr$nrows[i])
                                vv[is.na(a)] <- NA
                                return(vv)
                        }
                        snow::clusterExport(cl, c('tr', 'dx', 'dy', 'out', 'nl'), envir=environment())

                    for (i in 1:nodes) {
                                snow::sendCall(cl[[i]], clFun, list(i), tag=i)
                        }
                        for (i in 1:tr$n) {
                                d <- snow::recvOneData(cl)
                                if (! d$value$success ) { 
                                        print(d)
                                        stop('cluster error') 
                                }
                                if (filename == ) {
                                        r <- tr$row[d$value$tag]:(tr$row[d$value$tag]+tr$nrows[d$value$tag]-1)
                                        start <- (r[1]-1) * ncol(out) + 1
                                        end <- r[length(r)] * ncol(out) 
                                        v[start:end, ] <- d$value$value
                                } else {
                                        out <- writeValues(out, d$value$value, tr$row[d$value$tag])
                                }
                                if ((nodes + i) <= tr$n) {
#                                       snow::sendCall(cl[[d$node]], clFun, list(nodes+i, tr, dx, dy, out, nl), tag=nodes+i)
                                        snow::sendCall(cl[[d$node]], clFun, list(nodes+i), tag=nodes+i)
                                }
                                pbStep(pb, i)   
                        }               

                } else {
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='area', ...)

                #rows <- 1
                        for (i in 1:tr$n) {
                                r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1)
                                vv <- dx[r] * dy / 1000000
                                vv <- rep(vv, each=out@ncols)

                                vv <- matrix(rep(vv, times=nl), ncol=nl)
                                a <- getValues(x, tr$row[i], tr$nrows[i])
                                vv[is.na(a)] <- NA
                                if (filename == ) {
                                        start <- (r[1]-1) * ncol(out) + 1
                                        end <- r[length(r)] * ncol(out) 
                                        v[start:end, ] <- vv
                                } else {
                                        out <- writeValues(out, vv, tr$row[i])
                                }
                                pbStep(pb, i)
                        }
                        pbClose(pb)
                }

                if (filename == ) { 
                        if (weights) {
                                total <- colSums(v, na.rm=TRUE)
                                v <- t( t(v) / total )
                        }
                        values(out) <- v
                } else {
                        out <- writeStop(out)   
                        if (weights) {
                                total <- cellStats(out, 'sum')
                                out <- calc(out, fun=function(x){x / total}, filename=outfname, ...)
                        }
                }
                return(out)
        }
)

14 arith_sp.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
setMethod(+, signature(e1='SpatialPolygons', e2='SpatialPolygons'),
    function(e1, e2){ 
                union(e1, e2)
        }
)
setMethod(*, signature(e1='SpatialPolygons', e2='SpatialPolygons'),
    function(e1, e2){ 
                intersect(e1, e2)       }
)
setMethod(-, signature(e1='SpatialPolygons', e2='SpatialPolygons'),
    function(e1, e2){ 
                erase(e1, e2)
        }
)
#setMethod(^, signature(e1='SpatialPolygons', e2='SpatialPolygons'),
#    function(e1, e2){ 
#               crop(e1, e2)
#       }
#)

15 artith.R

# Author: Robert J. Hijmans
# Date :  January 2009
# Version 1.0
# Licence GPL v3
setMethod(Arith, signature(e1='Raster', e2='Raster'),
    function(e1, e2){ 
                if (!hasValues(e1)) { stop('first Raster object has no values') }
                if (!hasValues(e2)) { stop('second Raster object has no values') }

                nl1 <- nlayers(e1)
                nl2 <- nlayers(e2)
                nl <- max(nl1, nl2)
                proj1 <- projection(e1)
                proj2 <- projection(e2)

                if ( ! compareRaster(e1, e2, crs=FALSE, stopiffalse=FALSE) ) {
                        if ( compareRaster(e1, e2, extent=FALSE, rowcol=FALSE, crs=TRUE, res=TRUE, orig=TRUE, stopiffalse=TRUE) ) {
                                ie <- intersect(extent(e1), extent(e2))
                                if (is.null(ie)) {      stop() }
                                warning('Raster objects have different extents. Result for their intersection is returned')
                                e1 <- crop(e1, ie)
                                e2 <- crop(e2, ie)
                        } else {
                                stop()  # stops anyway because compareRaster returned FALSE
                        }
                }
                if (nl > 1) {
                        r <- brick(e1, values=FALSE, nl=nl)
                } else {
                        r <- raster(e1)
                }

                if (canProcessInMemory(r, 4)) {
                        if (nl1 == nl2 ) {
                                return( setValues(r, values=callGeneric( getValues(e1), getValues(e2))) )
                        } else {
                                return( setValues(r, matrix(callGeneric( as.vector(getValues(e1)), as.vector(getValues(e2))), ncol=nl)) )
                        }

                } else {

                        tr <- blockSize(e1)
                        pb <- pbCreate(tr$n, label='arith')
                        e1 <- readStart(e1)
                        e2 <- readStart(e2)
                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                        if (nl1 == nl2 ) {
                                for (i in 1:tr$n) {
                                        v1 <- getValues(e1, row=tr$row[i], nrows=tr$nrows[i])
                                        v2 <- getValues(e2, row=tr$row[i], nrows=tr$nrows[i])
                                        v <- callGeneric( v1, v2 )
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)   
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        v1 <- as.vector(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]))
                                        v2 <- as.vector(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))
                                        v <- matrix(callGeneric( v1, v2 ), ncol=nl)
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)   
                                }
                        }
                        r <- writeStop(r)
                        e1 <- readStop(e1)
                        e2 <- readStop(e2)
                        pbClose(pb)
                        return(r)

                }
        }       
)
setMethod(Arith, signature(e1='RasterLayer', e2='numeric'),
    function(e1, e2){ 
                if (!hasValues(e1)) { stop('RasterLayer has no values') }
                r <- raster(e1)
                names(r) <- names(e1)
                if (canProcessInMemory(e1, 4)) {
                        if (length(e2) > ncell(r)) {
                                e2 <- e2[1:ncell(r)]
                        }
                        return ( setValues(r,  callGeneric(as.numeric(getValues(e1)), e2) ) )

                } else {
                        tr <- blockSize(e1)
                        pb <- pbCreate(tr$n, label='arith')                     
                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                        e1 <- readStart(e1)
                        if (length(e2) > 0) {
                                for (i in 1:tr$n) {
                                        e <- .getAdjustedE(r, tr, i, e2)
                                        v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e)
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)   
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        v <- callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2 )
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }
                        r <- writeStop(r)
                        e1 <- readStop(e1)
                        pbClose(pb)
                        return(r)
                }               
        }
)
setMethod(Arith, signature(e1='numeric', e2='RasterLayer'),
    function(e1, e2){ 
                stopifnot(hasValues(e2))
                r <- raster(e2)
                names(r) <- names(e2)
                if (canProcessInMemory(e2, 4)) {
                        if (length(e1) > ncell(r)) {
                                e1 <- e1[1:ncell(r)]
                        }
                        return ( setValues(r,  callGeneric(e1, getValues(e2)) ) )

                } else {
                        tr <- blockSize(e2)
                        pb <- pbCreate(tr$n, label='arith')                     
                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                        e2 <- readStart(e2)
                        if (length(e1) > 0) {
                                for (i in 1:tr$n) {
                                        e <- .getAdjustedE(r, tr, i, e1)
                                        v <- callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)   
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        v <- callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }
                        r <- writeStop(r)
                        e2 <- readStop(e2)

                        pbClose(pb)
                        return(r)
                }               
        }
)
setMethod(Arith, signature(e1='RasterLayerSparse', e2='numeric'),
    function(e1, e2){ 

                if (!hasValues(e1)) { stop('RasterLayerSparse has no values') }
                stopifnot(length(e2) == 1)
                setValues(e1,  callGeneric(as.numeric(e1@data@values), e2))
        }
)
setMethod(Arith, signature(e1='numeric', e2='RasterLayerSparse'),
    function(e1, e2){ 
                if (!hasValues(e2)) { stop('RasterLayerSparse has no values') }
                stopifnot(length(e1) == 1)
                setValues(e2,  callGeneric(as.numeric(e2@data@values), e1) )
        }
)
setMethod(Arith, signature(e1='RasterLayer', e2='logical'),
    function(e1, e2){ 
                e2 <- as.integer(e2)
                callGeneric(e1, e2)
        }
)
setMethod(Arith, signature(e1='logical', e2='RasterLayer'),
    function(e1, e2){ 
                e1 <- as.integer(e1)
                callGeneric(e1, e2)
        }
)
setMethod(Arith, signature(e1='RasterStackBrick', e2='numeric'),
    function(e1, e2) {

                if (length(e2) > 1) {
                        nl <- nlayers(e1)
                        if (length(e2) != nl) {
                                a <- rep(NA, nl)
                                a[] <- e2
                                e2 <- a
                        }
                        b <- brick(e1, values=FALSE)
                        names(b) <- names(e1)

                        if (canProcessInMemory(e1, 3)) {
                                return( setValues(b, t(callGeneric( t(getValues(e1)), e2))) )
                        }

                        tr <- blockSize(b)
                        pb <- pbCreate(tr$n, label='arith')
                        b <- writeStart(b, filename=rasterTmpFile(), bandorder='BIL')
                        e1 <- readStart(e1)
                        for (i in 1:tr$n) {
                                v <- t (callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2) )
                                b <- writeValues(b, v, tr$row[i])
                                pbStep(pb, i)
                        }
                        b <- writeStop(b)
                        e1 <- readStop(e1)
                        pbClose(pb)
                        return(b)
                }

                # else:
                b <- brick(e1, values=FALSE)
                names(b) <- names(e1)

                if (canProcessInMemory(e1, 3)) {
                        return ( setValues(b,  callGeneric(getValues(e1), e2) ) )
                } else {
                        tr <- blockSize(b)
                        pb <- pbCreate(tr$n, label='arith')
                        b <- writeStart(b, filename=rasterTmpFile())
                        e1 <- readStart(e1)
                        for (i in 1:tr$n) {
                                v <- callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2)
                                b <- writeValues(b, v, tr$row[i])
                                pbStep(pb, i)
                        }
                        b <- writeStop(b)
                        e1 <- readStop(e1)
                        pbClose(pb)
                        return(b)
                }
        }
)
setMethod(Arith, signature(e1='numeric', e2='RasterStackBrick'),
    function(e1, e2) {

                if (length(e1) > 1) {
                        nl <- nlayers(e2)
                        if (length(e1) != nl) {
                                a <- rep(NA, nl)
                                a[] <- e1
                                e1 <- a
                        }

                        b <- brick(e2, values=FALSE)
                        names(b) <- names(e2)

                        if (canProcessInMemory(e2, 3)) {
                                return( setValues(b, t(callGeneric( e1, t(getValues(e2))))) )
                        }

                        tr <- blockSize(b)
                        pb <- pbCreate(tr$n, label='arith')
                        e2 <- readStart(e2)
                        b <- writeStart(b, filename=rasterTmpFile())
                        for (i in 1:tr$n) {
                                v <- t (callGeneric( e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) )
                                b <- writeValues(b, v, tr$row[i])
                                pbStep(pb, i)
                        }
                        b <- writeStop(b)
                        e2 <- readStop(e2)
                        pbClose(pb)
                        return(b)
                }

                # else:
                b <- brick(e2, values=FALSE)
                names(b) <- names(e2)

                if (canProcessInMemory(e2, 3)) {
                        return ( setValues(b,  callGeneric(e1, getValues(e2)) ) )
                } else {

                        tr <- blockSize(b)
                        pb <- pbCreate(tr$n, label='arith')
                        b <- writeStart(b, filename=rasterTmpFile())
                        e2 <- readStart(e2)
                        for (i in 1:tr$n) {
                                v <- callGeneric( e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))
                                b <- writeValues(b, v, tr$row[i])
                                pbStep(pb, i)
                        }
                        b <- writeStop(b)
                        e2 <- readStop(e2)
                        pbClose(pb)
                        return(b)
                }
        }
)
setMethod(Arith, signature(e1='RasterStackBrick', e2='logical'),  # for Arith with NA
    function(e1, e2){ 
                e2 <- as.integer(e2)
                callGeneric(e1, e2)
        }
)
setMethod(Arith, signature(e1='logical', e2='RasterStackBrick'),
    function(e1, e2){ 
                e1 <- as.integer(e1)
                callGeneric(e1, e2)
        }
)
setMethod(Arith, signature(e1='Extent', e2='numeric'),
        function(e1, e2){ 

                if (length(e2) == 1) {
                        x1 = e2
                        x2 = e2
                } else if (length(e2) == 2) {
                        x1 = e2[1]
                        x2 = e2[2]
                } else if (length(e2) == 4) {
                        return(extent(callGeneric(as.vector(e1), e2)))
                } else {
                        stop('On an Extent object, you can only use Arith with a single number or with two numbers')
                }
                r <- e1@xmax - e1@xmin
                d <- callGeneric(r, x1)
                d <- (d - r) / 2
                e1@xmax <- e1@xmax + d
                e1@xmin <- e1@xmin - d

                r <- e1@ymax - e1@ymin
                d <- callGeneric(r, x2)
                d <- (d - r) / 2
                e1@ymax <- e1@ymax + d
                e1@ymin <- e1@ymin - d
                return(e1)
        }
)
setMethod(Arith, signature(e1='numeric', e2='Extent'),
    function(e1, e2){ 
                callGeneric(e2,e1)
        }
)

16 as.array.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : November 2010
# Version 1.0
# Licence GPL v3
setMethod('as.array', signature(x='RasterLayer'), 
function(x, maxpixels, ...) {
        if (!hasValues(x)) { stop('x' has no values) }
        if (! missing(maxpixels)) {
                x <- sampleRegular(x, maxpixels, asRaster=TRUE)
        }
        x <- array(as.matrix(x), c(dim(x)))
        x
} )
setMethod('as.array', signature(x='RasterStackBrick'), 
function(x, maxpixels, transpose=FALSE) {
        if (!hasValues(x)) { stop('x' has no values) }
        if (! missing(maxpixels)) {
                x <- sampleRegular(x, maxpixels, asRaster=TRUE)
        }
        dm <- dim(x)
        x <- getValues(x)
        if (transpose) {
                ar <- array(NA, c(dm[2], dm[1], dm[3]))
                for (i in 1:dm[3]) {
                        ar[,,i] <- matrix(x[,i], nrow=dm[2], byrow=FALSE)
                }       
        } else {
                ar <- array(NA, dm)
                for (i in 1:dm[3]) {
                        ar[,,i] <- matrix(x[,i], nrow=dm[1], byrow=TRUE)
                }
        }
        ar
} )

17 as.data.frame.R

# Author: Robert J. Hijmans
# Date : July 2011
# Version 1.0
# Licence GPL v3
if (!isGeneric(as.data.frame)) {
        setGeneric(as.data.frame, function(x, row.names = NULL, optional = FALSE, ...)
                standardGeneric(as.data.frame))
}       
.insertColsInDF <- function(x, y, col, combinenames=TRUE) {
        cnames <- NULL
        if (combinenames) {
                if (ncol(y) > 1) {
                        cnames <- paste(colnames(x)[col], '_', colnames(y), sep='')
                }
        }
        if (ncol(y) == 1) {
                x[, col] <- y
                return(x)
        } else if (col==1) {
                z <- cbind(y, x[, -1, drop=FALSE])
        } else if (col==ncol(x)) {
                z <- cbind(x[, -ncol(x), drop=FALSE], y)
        } else {
                z <- cbind(x[,1:(col-1), drop=FALSE], y, x[,(col+1):ncol(x), drop=FALSE])
        }
        if (!is.null(cnames)) {
                colnames(z)[col:(col+ncol(y)-1)] <- cnames
        }
        z
}
setMethod('as.data.frame', signature(x='Raster'), 
        function(x, row.names = NULL, optional = FALSE, xy=FALSE, na.rm=FALSE, ...) {
                if (!canProcessInMemory(x, 4) & na.rm) {
                        r <- raster(x)
                        ncx <- ncol(r)
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='as.data.frame', ...)
                        x <- readStart(x)
                        v <- NULL
                        for (i in 1:tr$n) {
                                start <- (tr$row[i]-1) * ncx + 1
                                end <- start + tr$nrows[i] * ncx - 1
                                vv <- cbind(start:end, getValues(x, row=tr$row[i], nrows=tr$nrows[i]))
                                if (xy) {
                                        XY <- data.frame(xyFromCell(r, start:end))
                                        vv <- na.omit(vv, XY)
                                }
                                v <- rbind(v, vv)
                                pbStep(pb, i)   
                        }
                        x <- readStop(x)
                } else {
                        v <- getValues(x)
                        if (xy) {
                                XY <- data.frame(xyFromCell(x, 1:ncell(x)))
                                v <- cbind(XY, v)
                        }
                        if (na.rm) {
                                v <- na.omit(cbind(1:ncell(x), v))
                        }
                }

                v <- as.data.frame(v, row.names=row.names, optional=optional, ...)
                if (na.rm) {
                        rownames(v) <- as.character(v[,1])
                        v <- v[,-1,drop=FALSE]
                } 

                if (nlayers(x) == 1) {
                        colnames(v)[ncol(v)] <- names(x)  # for nlayers = 1
                }

                i <- is.factor(x)
                if (any(is.factor(x))) {
                        if (ncol(v) == 1) {
                                v <- data.frame( factorValues(x, v[,1], 1))
                #               j <- which(sapply(v, is.character))
                #               if (length(j) > 0) {
                #                       for (jj in j) {
                #                               v[, jj] <- as.factor(v[,jj])
                #                       }
                #               }
                        } else {
                                nl <- nlayers(x)
                                if (ncol(v) > nl) {
                                        rnge1 <- 1:(ncol(v)-nl)
                                        rnge2 <- (ncol(v)-nl+1):ncol(v)
                                        v <- cbind(v[, rnge1], .insertFacts(x, v[, rnge2], 1:nl))
                                } else {
                                        v <- .insertFacts(x, v, 1:nl)
                                }
                        }
                }
                v
        }
)
setMethod('as.data.frame', signature(x='SpatialPolygons'), 
        function(x, row.names=NULL, optional=FALSE, xy=FALSE, centroids=TRUE, sepNA=FALSE, ...) {

                if (!xy) {
                        if (.hasSlot(x, 'data')) {
                                return( x@data )
                        } else {
                                return(NULL)
                        }
                }               
                if (centroids) {
                        xy <- coordinates(x)
                        xy <- cbind(1:nrow(xy), xy)
                        colnames(xy) <- c('object', 'x', 'y')
                        xy <- as.data.frame(xy, row.names=row.names, optional=optional, ...)
                        if (.hasSlot(x, 'data')) {
                                return( cbind(xy, x@data ) )
                        } else {
                                return(xy)
                        }
                }

                nobs <- length(x@polygons)
                objlist <- list()
                cnt <- 0
                if (sepNA) {
                        sep <- rep(NA,5)
                        for (i in 1:nobs) {
                                nsubobs <- length(x@polygons[[i]]@Polygons)
                                ps <- lapply(1:nsubobs, 
                                                function(j)
                                                        rbind(cbind(j, j+cnt, x@polygons[[i]]@Polygons[[j]]@hole, x@polygons[[i]]@Polygons[[j]]@coords), sep)
                                                )
                                objlist[[i]] <- cbind(i, do.call(rbind, ps))
                                cnt <- cnt+nsubobs
                        }
                } else {
                        for (i in 1:nobs) {
                                nsubobs <- length(x@polygons[[i]]@Polygons)
                                ps <- lapply(1:nsubobs, 
                                                function(j) 
                                                        cbind(j, j+cnt, x@polygons[[i]]@Polygons[[j]]@hole, x@polygons[[i]]@Polygons[[j]]@coords)
                                                )
                                objlist[[i]] <- cbind(i, do.call(rbind, ps))
                                cnt <- cnt+nsubobs
                        }
                }

                obs <- do.call(rbind, objlist)
                colnames(obs) <- c('object', 'part', 'cump', 'hole', 'x', 'y')
                rownames(obs) <- NULL

                obs <- as.data.frame(obs, row.names=row.names, optional=optional, ...)

                if (.hasSlot(x, 'data')) {
                        d <- x@data
                        d <- data.frame(object=1:nrow(x), x@data)
                        obs <- merge(obs, d, by=1)
                } 
                if (sepNA) {
                        obs[is.na(obs[,2]), ] <- NA
                }
                return( obs )
        }
)
setMethod('as.data.frame', signature(x='SpatialLines'), 
        function(x, row.names=NULL, optional=FALSE, xy=FALSE, sepNA=FALSE, ...) {

                if (!xy) {
                        if (.hasSlot(x, 'data')) {
                                return( x@data )
                        } else {
                                return(NULL)
                        }
                }

                nobj <- length(x@lines)
                objlist <- list()
                cnt <- 0
                if (sepNA) {
                        sep <- rep(NA, 4)
                        for (i in 1:nobs) {
                                nsubobj <- length(x@lines[[i]]@Lines)
                                ps <- lapply(1:nsubobj, 
                                                function(j) 
                                                        rbind(cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords), sep)
                                                )
                                objlist[[i]] <- cbind(i, do.call(rbind, ps))
                                cnt <- cnt+nsubobj
                        }
                } else {
                        for (i in 1:nobj) {
                                nsubobj <- length(x@lines[[i]]@Lines)
                                ps <- lapply(1:nsubobj, function(j) cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords))
                                objlist[[i]] <- cbind(i, do.call(rbind, ps))
                                cnt <- cnt+nsubobj
                        }
                }
                obs <- do.call(rbind, objlist)
                colnames(obs) <- c('object', 'part', 'cump', 'x', 'y')
                rownames(obs) <- NULL
                obs <- as.data.frame(obs, row.names=row.names, optional=optional, ...)

                if (.hasSlot(x, 'data')) {
                        d <- x@data
                        d <- data.frame(object=1:nrow(x), x@data)
                        obs <- merge(obs, d, by=1)
                } 
                if (sepNA) {
                        obs[is.na(obs[,2]), ] <- NA
                }
                return (obs)
        }
)
setMethod('as.data.frame', signature(x='SpatialPoints'), 
        function(x, row.names=NULL, optional=FALSE, xy=TRUE, ...) {
                if (!xy) {
                        if (.hasSlot(x, 'data')) {
                                return( x@data )
                        } else {
                                return(NULL)
                        }
                }

                nobj <- length(x)
                d <- coordinates(x)
                if (.hasSlot(x, 'data')) {
                        d <- cbind(d, x@data)
                }
                colnames(d)[1:2] <- c('x', 'y')
                rownames(d) <- NULL
                as.data.frame(d, row.names=row.names, optional=optional, ...)
        }
)
#setMethod('as.data.frame', signature(x='SpatialPoints'), 
#       function(x, row.names=NULL, optional=FALSE, xy=TRUE, ...) {
#               
#               if (!xy) {
#                       if (.hasSlot(x, 'data')) {
#                               return( x@data )
#                       } else {
#                               return(NULL)
#                       }
#               } else {
#                       xy <- coordinates(x)
#                       xy <- cbind(1:nrow(xy), xy)
#                       colnames(xy) <- c('object', 'x', 'y')
#                       xy <- as.data.frame(xy, row.names=row.names, optional=optional, ...)
#                       if (.hasSlot(x, 'data')) {
#                               xy <- data.frame(xy, x@data )
#                       } 
#                       return(xy)
#               }
#       }
#)

18 as.logical.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date: November 2009
# Version 0.9
# Licence GPL v3
setMethod('as.logical', signature(x='Raster'), 
function(x, filename='', ...) {

        if (nlayers(x) > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)
        }

        if (canProcessInMemory(x, 2)){

                x <- getValues(x)
                x[] <- as.logical(x)
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename, datatype='INT2S', ...)
                }
                return(out)

        } else {
                if (filename == '') {
                        filename <- rasterTmpFile()                                     
                }

                out <- writeStart(out, filename=filename, ...)
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, ...)       
                for (i in 1:tr$n) {
                        v <- as.logical ( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) )
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i) 
                } 
                pbClose(pb)                     
                out <- writeStop(out)           
                return(out)
        }
}
)

19 as.matrix.R

# Author: Robert J. Hijmans 
# Date : October 2010
# Version 1.0
# Licence GPL v3
setMethod('as.matrix', signature(x='RasterLayer'), 
function(x, maxpixels, ...) {
        if (!hasValues(x)) { stop('x' has no values) }
        if (! missing(maxpixels)) {
                x <- sampleRegular(x, maxpixels, asRaster=TRUE)
        }
        return( getValues(x, format='matrix') )
})
setMethod('as.matrix', signature(x='RasterStackBrick'), 
function(x, maxpixels, ...){ 
        if (!hasValues(x)) { stop('x' has no values) }
        if (! missing(maxpixels)) {
                x <- sampleRegular(x, maxpixels, asRaster=TRUE)
        }
        return( getValues(x) )
})
setMethod('as.matrix', signature(x='Extent'), 
function(x, ...) {
        b <- bbox(x)
        rownames(b) <- c('x', 'y')
        b
})
setMethod('as.vector', signature(x='Extent'), 
function(x,  mode = any) {
        as.vector(c(x@xmin, x@xmax, x@ymin, x@ymax), mode=mode)
})
setMethod('as.vector', signature(x='Raster'), 
function(x,  mode = any) {
        as.vector(getValues(x), mode=mode)
})

20 as.raster.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : July 2011
# Version 0.9
# Licence GPL v3
# Note: these functions create a _r_aster object (small r) (grDevices) for use with the rasterImage function
# _NOT_ a Raster* object as defined in this package

if (!isGeneric(as.raster)) {
        setGeneric(as.raster, function(x, ...)
                standardGeneric(as.raster))
}       
setMethod('as.raster', signature(x='RasterLayer'), 
function(x, maxpixels=50000, col=rev(terrain.colors(255)), ...) {
        x <- as.matrix(sampleRegular(x, maxpixels, asRaster=TRUE))
        r <- range(x, na.rm=TRUE)
        x <- (x - r[1])/ (r[2] - r[1])
        x <- round(x * (length(col)-1) + 1)
        x[] <- col[x]
        as.raster(x)
} )
#e <- as.vector(t(bbox(extent(r))))
#a <- as.raster(r)
#plot(e[1:2], e[3:4], type = n, xlab=, ylab=)
#rasterImage(a, e[1], e[3], e[2], e[4])

21 as.spatial.R

setAs('data.frame', 'SpatialPolygons',
        function(from) {
                obs <- unique(from$object)
                sp <- list()
                for (i in 1:length(obs)) {
                        s <- from[from$object==obs[i], ]
                        p <- unique(s$part)
                        pp <- list()
                        for (j in 1:length(p)) {
                                ss <- s[s$part==p[j], ]
                                pol <- Polygon(as.matrix(ss)[,5:6])
                                if (ss$hole[1]) {
                                        pol@hole <- TRUE
                                }
                                pp[[j]] <- pol
                        }
                        sp[[i]] <- Polygons(pp, as.character(i))
                }

                SpatialPolygons(sp)
        }
)
setAs('data.frame', 'SpatialPolygonsDataFrame',
        function(from) {
                x <- as(from, 'SpatialPolygons')
                if (ncol(from) > 6) {
                        d <- unique(from[, -c(2:6), drop=FALSE])
                        rownames(d) <- d$object
                        d <- d[, -1, drop=FALSE]
                        SpatialPolygonsDataFrame(x, d)
                } else {
                        x
                }
        }
)
setAs('data.frame', 'SpatialLines',
        function(from) {
                obs <- unique(from$object)
                sp <- list()
                for (i in 1:length(obs)) {
                        s <- from[from$object==obs[i], ]
                        p <- unique(s$part)
                        pp <- list()
                        for (j in 1:length(p)) {
                                ss <- s[s$part==p[j], ]
                                ln <- Line(as.matrix(ss)[,c('x', 'y')])
                                pp[[j]] <- ln
                        }
                        sp[[i]] <- Lines(pp, as.character(i))
                }
                SpatialLines(sp)
        }
)
setAs('data.frame', 'SpatialLinesDataFrame',
        function(from) {
                x <- as(from, 'SpatialLines')
                if (ncol(from) > 5) {
                        d <- unique(from[, -c(2:5), drop=FALSE])
                        rownames(d) <- d$object
                        d <- d[, -1, drop=FALSE]
                        SpatialLinesDataFrame(x, d)
                } else {
                        x
                }
        }
)

22 atan2.R

# Author: Robert J. Hijmans
# Date : March 2011
# Version 1.0
# Licence GPL v3
if (!isGeneric(atan2)) {
        setGeneric(atan2, function(y, x)
                standardGeneric(atan2))
}       
setMethod(atan2, signature(y='RasterLayer', x='RasterLayer'),
        function(y, x) { 

                r <- raster(x)
                compareRaster(r, y)

                if (canProcessInMemory(r, 3)) {
                        r <- setValues(r, atan2(getValues(y), getValues(x)))
                } else {
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n)
                        r <- writeStart(r, filename=rasterTmpFile())
                        for (i in 1:tr$n) {
                                v <- atan2(getValues(y, row=tr$row[i], nrows=tr$nrows[i]), getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) 
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                }
                return(r)
        }
)

23 bands.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(bandnr)) {
        setGeneric(bandnr, function(x, ...)
                standardGeneric(bandnr))
}       
setMethod('bandnr', signature(x='RasterLayer'), 
function(x) {
        return(x@data@band)
}
)
nbands <- function(x) {
        cx = class(x)
        if (inherits(x, RasterLayer) | inherits(x, RasterBrick)) {
                return(x@file@nbands)
        } else {
                stop(paste(not implemented for, class(x), objects))
        }       
}
.bandOrder <- function(x) {
        if (inherits(x, RasterStack)) {
                stop(paste(not implemented for RasterStack objects))
        } else {
                return(paste(x@file@bandorder))
        }
}

24 barplot.R

# Author: Robert J. Hijmans
# Date :  September 2012
# Version 1.0
# Licence GPL v3
if (!isGeneric(barplot)) {
        setGeneric(barplot, function(height,...)
                standardGeneric(barplot))
}       
setMethod('barplot', 'RasterLayer', 
        function(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...)  {

                x <- sampleRegular(height, maxpixels)
                adj <- length(x) / ncell(height)
                if (adj < 1) {
                        warning('a sample of ', round(100*adj, 1), '% of the raster cells were used to estimate frequencies')
                }
                if (!is.null(digits)) {
                        x <- round(x, digits)
                }
                if (!is.null(breaks)) {
                        x <- cut(x, breaks)
                }

                x <- table(x) / adj
                if (is.function(col)) {
                        col <- col(length(x))
                }
                barplot(x, col=col, ...)
        }
)

25 bbox.R

# R function for the raster package
# Author: Robert J. Hijmans
# contact: r.hijmans@gmail.com
# Date : January 2009
# Version 0.9
# Licence GPL v3
setMethod('bbox', signature(obj='Extent'), 
        function(obj) {
                bb <- matrix(ncol=2, nrow=2)
                colnames(bb) <- c(min,max)
                rownames(bb) <- c(s1,s2)
                bb[1,1] <- obj@xmin
                bb[1,2] <- obj@xmax
                bb[2,1] <- obj@ymin
                bb[2,2] <- obj@ymax
                return(bb)
        }       
)
setMethod('bbox', signature(obj='Raster'), 
        function(obj) {
                obj <- extent(obj)
                return( bbox(obj) )
        }       
)

26 bilinearValue.R

# Author: Robert J. Hijmans
# Date :  March  2009
# Licence GPL v3
# updated November 2011
# version 1.0
.bilinearValue <- function(raster, xyCoords, layer, n) {

        bilinear_old <- function(x, y, x1, x2, y1, y2, v) {
                v <- v / ((x2-x1)*(y2-y1))
                return( v[,1]*(x2-x)*(y2-y) + v[,3]*(x-x1)*(y2-y) + v[,2]*(x2-x)*(y-y1) + v[,4]*(x-x1)*(y-y1) )
                #div <- (x2-x1)*(y2-y1)
                #return ( (v[,1]/div)*(x2-x)*(y2-y) + (v[,3]/div)*(x-x1)*(y2-y) + (v[,2]/div)*(x2-x)*(y-y1) + (v[,4]/div)*(x-x1)*(y-y1) )
        }

        bilinear <- function(xy, x, y, v) {
                v <- v / ((x[2,]-x[1,])*(y[2,]-y[1,]))
                return( v[,1]*(x[2,]-xy[,1])*(y[2,]-xy[,2]) + v[,3]*(xy[,1]-x[1,])*(y[2,]-xy[,2]) + 
                                v[,2]*(x[2,]-xy[,1])*(xy[,2]-y[1,]) + v[,4]*(xy[,1]-x[1,])*(xy[,2]-y[1,]) )
        }

        r <- raster(raster)
        nls <- nlayers(raster)

        four <- fourCellsFromXY(r, xyCoords, duplicates=FALSE)

        xy4 <- matrix(xyFromCell(r, as.vector(four)), ncol=8)
        x <- apply(xy4[,1:4,drop=FALSE], 1, range)
        y <- apply(xy4[,5:8,drop=FALSE], 1, range)
        xy4 <- cbind(c(x[1,], x[1,], x[2,], x[2,]), c(y[1,], y[2,], y[1,], y[2,]))
        cells <- cellFromXY(r, xy4)
        w <- getOption('warn')
        options('warn'=-1) 
        row1 <- rowFromCell(r, min(cells, na.rm=TRUE))
        options('warn' = w)
        if (is.na(row1)) {
                if (nls == 1) {
                        return(rep(NA, nrow(xyCoords)))
                } else {
                        return(matrix(NA, nrow= nrow(xyCoords), ncol=nls))
                }
        }

        nrows <- rowFromCell(r, max(cells, na.rm=TRUE)) - row1 + 1
        offs <- cellFromRowCol(r, row1, 1) - 1
        cells <- cells - offs

        if (nls == 1) {
                vv <- getValues(raster, row1, nrows)
                v <- matrix( vv[cells], ncol=4)
                res <- rep(NA, nrow(v))
                rs <- rowSums(is.na(v))
                i <- rs==3
                if (sum(i) > 0) {
                        cells <- cellFromXY(raster, xyCoords[i,]) - offs
                        res[i] <- vv[cells]
                }
                i <- rs > 0 & rs < 3
                if (sum(i) > 0) {
                        vv <- v[i,,drop=FALSE]
                        vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2]
                        vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1]
                        vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4]
                        vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3]
                        vmean <- rep(rowMeans(vv, na.rm=TRUE), 4)
                        vv[is.na(vv)] <- vmean[is.na(vv)]
#                       res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], vv)
                        res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv)
                }
                i <- rs==0
                if (sum(i) > 0) {
#                       res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], v[i,])
                        res[i] <- bilinear(xyCoords[i, ,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE])
                }
                res

        } else {

                if (missing(layer)) { layer <- 1 }
                if (missing(n)) { n <- (nls-layer+1) }
                lyrs <- layer:(layer+n-1)
                allres <- matrix(ncol=length(lyrs), nrow=nrow(xyCoords))
                colnames(allres) <- names(raster)[lyrs]
                cvv <- getValues(raster, row1, nrows)[, lyrs]
                cv <- cvv[cells,]
                for (j in 1:ncol(cv)) {
                        v <- matrix(cv[, j], ncol=4)

                        res <- rep(NA, nrow(v))
                        rs <- rowSums(is.na(v))
                        i <- rs==3
                        if (sum(i) > 0) {
                                cells <- cellFromXY(raster, xyCoords[i,]) - offs
                                res[i] <- cvv[cells, j]
                        }
                        i <- rs > 0 & rs < 3
                        if (sum(i) > 0) {
                                vv <- v[i,,drop=FALSE]
                                vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2]
                                vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1]
                                vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4]
                                vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3]
                                vmean <- rep(rowMeans(vv, na.rm=TRUE), 4)
                                vv[is.na(vv)] <- vmean[is.na(vv)]
                                res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv)
                        }
                        i <- rs==0
                        if (sum(i) > 0) {
                                res[i] <- bilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE])
                        }
                        allres[,j] <- res
                }
                allres
        }
}

27 bind.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
.uniqueNames <- function(x, sep='.') {
        y <- as.matrix(table(x))
        y <- y[y[,1] > 1, ,drop=F]
        if (nrow(y) > 0) {
                y <- rownames(y)
                for (i in 1:length(y)) {
                        j <- which(x==y[i])
                        x[j] <- paste(x[j], sep, 1:length(j), sep='')
                }
        }
        x
}
if (!isGeneric(bind)) {
        setGeneric(bind, function(x, y, ...)
                standardGeneric(bind))
}       
setMethod('bind', signature(x='SpatialPolygons', y='SpatialPolygons'), 
function(x, y, ..., keepnames=FALSE) {
                x <- list(x, y, ...)
                #p <- sapply(x, proj4string)
                #if (!isTRUE(all(p==p[1]))) { }
                haswarned <- FALSE
                projx <- proj4string(x[[1]])
                for (i in 2:length(x)) {
                        if (is.na(proj4string(x[[i]]))) {
                                x[[i]]@proj4string <- x[[1]]@proj4string                        
                        } else if (! identical(projx, proj4string(x[[i]])) ) {
                                if (!haswarned) {
                                        warning('non identical CRS')
                                        haswarned <- TRUE
                                }
                                x[[i]]@proj4string <- x[[1]]@proj4string
                        }
                }       

                rwn <- lapply(x, row.names)
                i <- sapply(rwn, length) > 0
                if (!all(i)) {
                        if (!any(i)) {
                                return(x[[1]])
                        }
                        x <- x[i]
                        if (length(x) == 1) {
                                return( x[[1]] )
                        }
                }
                ln <- sapply(rwn, length)
                rnu <- .uniqueNames(unlist(rwn))
                end <- cumsum(ln)
                start <- c(0, end[-length(end)]) + 1
                for (i in 1:length(x)) {
                        if (keepnames) {
                                if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) {
                                        row.names(x[[i]]) <- rnu[start[i]:end[i]]
                                }
                        } else {
                                row.names(x[[i]]) <- as.character(start[i]:end[i])
                        }       
                }
                cls <- sapply(x, class)
                if (all(cls == 'SpatialPolygons')) {
                        return( do.call( rbind, x))
                }
                if (all(cls == 'SpatialPolygonsDataFrame')) {
                        dat <- lapply( x, function(x) { slot(x, 'data') } )
                        dat <- do.call(.frbind, dat)
                        x <- sapply(x, function(y) as(y, 'SpatialPolygons'))
                        x <- do.call( rbind, x)
                        rownames(dat) <- row.names(x)
                        return( SpatialPolygonsDataFrame(x, dat) )
                }

                dat <- NULL
#               dataFound <- FALSE
                for (i in 1:length(x)) {
                        if (.hasSlot(x[[i]], 'data')) {
#                               dataFound <- TRUE
                                if (is.null(dat)) {
                                        dat <- x[[i]]@data
                                } else {
                                        dat <- .frbind(dat, x[[i]]@data)
                                }
                        } else {
                                if ( is.null(dat)) {
                                        dat <- data.frame()
                                        dat[1:length(x[[i]]@polygons),] <- NA
                                        rownames(dat) <- row.names(x[[i]])
                                } else {
                                        dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])),] <- NA
                                }       
                        }
                }
#               if (! dataFound ) { return( do.call(rbind, x) ) }
                x <- sapply(x, function(x) as(x, 'SpatialPolygons'))
                x <- do.call(rbind, x)
                SpatialPolygonsDataFrame(x, dat)
}
)
setMethod('bind', signature(x='SpatialLines', y='SpatialLines'), 
        function(x, y, ..., keepnames=FALSE) {
                x <- list(x, y, ...)
                haswarned <- FALSE
                projx <- proj4string(x[[1]])
                for (i in 2:length(x)) {
                        if (is.na(proj4string(x[[i]]))) {
                                x[[i]]@proj4string <- x[[1]]@proj4string                        
                        } else if (! identical(projx, proj4string(x[[i]])) ) {
                                if (!haswarned) {
                                        warning('non identical CRS')
                                        haswarned <- TRUE
                                }
                                x[[i]]@proj4string <- x[[1]]@proj4string
                        }
                }       


                rwn <- lapply(x, row.names)
                i <- sapply(rwn, length) > 0
                if (!all(i)) {
                        if (!any(i)) {
                                return(x[[1]])
                        }
                        x <- x[i]
                        if (length(x) == 1) {
                                return( x[[1]] )
                        }
                }
                ln <- sapply(rwn, length)
                rnu <- .uniqueNames(unlist(rwn))
                end <- cumsum(ln)
                start <- c(0, end[-length(end)]) + 1
                for (i in 1:length(x)) {
                        if (keepnames) {
                                if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) {
                                        row.names(x[[i]]) <- rnu[start[i]:end[i]]
                                }
                        } else {
                                row.names(x[[i]]) <- as.character(start[i]:end[i])
                        }       
                }
                cls <- sapply(x, class)
                if (all(cls == 'SpatialLines')) {
                        return( do.call( rbind, x))
                }
                if (all(cls == 'SpatialLinesDataFrame')) {
                        dat <- lapply( x, function(x) { slot(x, 'data') } )
                        dat <- do.call(.frbind, dat)
                        x <- sapply(x, function(y) as(y, 'SpatialLines'))
                        x <- do.call( rbind, x)
                        rownames(dat) <- row.names(x)
                        return( SpatialLinesDataFrame(x, dat) )
                }

                dat <- NULL
#               dataFound <- FALSE
                for (i in 1:length(x)) {
                        if (.hasSlot(x[[i]], 'data')) {
#                               dataFound <- TRUE
                                if (is.null(dat)) {
                                        dat <- x[[i]]@data
                                } else {
                                        dat <- .frbind(dat, x[[i]]@data)
                                }
                        } else {
                                if ( is.null(dat)) {
                                        dat <- data.frame()
                                        dat[1:length(x[[i]]@lines),] <- NA
                                        rownames(dat) <- row.names(x[[i]])
                                } else {
                                        dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA
                                }       
                        }
                }
#               if (! dataFound ) { return( do.call(rbind, x) ) }
                x <- sapply(x, function(x) as(x, 'SpatialLines'))
                x <- do.call(rbind, x)
                SpatialLinesDataFrame(x, dat)
}
)
setMethod('bind', signature(x='SpatialPoints', y='SpatialPoints'),
        function(x, y, ..., keepnames=FALSE) {
                x <- list(x, y, ...)
                rwn <- lapply(x, row.names)
                i <- sapply(rwn, length) > 0
                if (!all(i)) {
                        if (!any(i)) {
                                return(x[[1]])
                        }
                        x <- x[i]
                        if (length(x) == 1) {
                                return( x[[1]] )
                        }
                }
                ln <- sapply(rwn, length)
                rnu <- .uniqueNames(unlist(rwn))
                end <- cumsum(ln)
                start <- c(0, end[-length(end)]) + 1
                for (i in 1:length(x)) {
                        if (keepnames) {
                                if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) {
                                        row.names(x[[i]]) <- rnu[start[i]:end[i]]
                                }
                        } else {
                                row.names(x[[i]]) <- as.character(start[i]:end[i])
                        }       
                }
                cls <- sapply(x, class)
                if (all(cls == 'SpatialPoints')) {
                        return( do.call( rbind, x))
                }
                if (all(cls == 'SpatialPointsDataFrame')) {
                        dat <- lapply( x, function(x) { slot(x, 'data') } )
                        dat <- do.call(.frbind, dat)
                        x <- sapply(x, function(y) as(y, 'SpatialPoints'))
                        x <- do.call( rbind, x)
                        rownames(dat) <- row.names(x)
                        return( SpatialPointsDataFrame(x, dat) )
                }

                dat <- NULL
                for (i in 1:length(x)) {
                        if (.hasSlot(x[[i]], 'data')) {
                                if (is.null(dat)) {
                                        dat <- x[[i]]@data
                                } else {
                                        dat <- .frbind(dat, x[[i]]@data)
                                }
                        } else {
                                if ( is.null(dat)) {
                                        dat <- data.frame()
                                        dat[1:nrow(x[[i]]@coords),] <- NA
                                        rownames(dat) <- row.names(x[[i]])
                                } else {
                                        dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA
                                }       
                        }
                }
#               if (! dataFound ) { return( do.call(rbind, x) ) }
                x <- sapply(x, function(x) as(x, 'SpatialPoints'))
                x <- do.call(rbind, x)
                SpatialPoinsDataFrame(x, dat)
}
)

28 blend.R

# Authors: Rafael Wueest, WSL Birmensdorf, Switzerland, rafael.wueest@wsl.ch, 
# Etienne B. Racine, Robert J. Hijmans
# Date : November 2012
# Version 1.0
# Licence GPL v3
# needs to be generalized to n input rasters and to multi-layer objects
.old_blend <- function(r1, r2) {
        i <- intersect(raster(r1), raster(r2))
        j <- extend(i, c(1,1)) 
        a <- crop(r1, j)
        b <- crop(r2, j)
        values(a) <- 1
        values(b) <- 2
        ab <- merge(a, b)
        ba <- merge(b, a)
        p1 <- rasterToPoints(ab, function(x) x==2)
        p2 <- rasterToPoints(ba, function(x) x==1)
        d1 <- distanceFromPoints(i, p1[,1:2])
        d2 <- distanceFromPoints(i, p2[,1:2])
        dsum <- d1 + d2
        z1 <- d1 * crop(r1, d1) / dsum
        z2 <- d2 * crop(r2, d2) / dsum
        merge(z1 + z2, r1, r2)
}
.blend <- function(x, y, logistic=FALSE, filename='', ...) {

   # check for difference in extent
        stopifnot( extent(x) != extent(y))

   # define logistic function
   if (logistic) {
                G <- 1
                f <- 0.001
                k <- log(G/f-1)/(0.5*G)
                logfun <- function(x) { 
                        G /(1+exp(-k*G*x)*(G/f-1)) 
                }
        }

   # create intersection rasters
        i <- intersect(raster(x), raster(y))
        j <- extend(i, c(1,1)) 

   # is one of the rasters nested within the other?
        ex <- extent(x)
        ey <- extent(y)
        exy <- union(ex, ey)
        if (exy==ex | exy==ey){    # the nested case

      # which raster has the smaller extent?
                if (extent(x) < extent(y)){
                        rlarge <- y
                        rsmall <- x
                } else {
                        rlarge <- x
                        rsmall <- y
                }

      # create points around nested raster
                a <- crop(rlarge, j)
                a <- setValues(a, 1)
                b <- crop(rsmall, j)
                b <- setValues(b, 2)
                ba <- merge(b, a)
                p <- rasterToPoints(ba, function(x) x==1)

      # calculate distances to points in nested raster
                d <- distanceFromPoints(i, p[,1:2])

      # standardize these distances
                dmin <- cellStats(d,'min')
                d.sc <- (d - dmin + 1e-9) / (cellStats(d,'max') - dmin)

      # the logistic case
                if(logistic){
                        d.sc<-logfun(d.sc)
                }

      # create distance weighted rasters
                z1 <- d.sc * crop(rsmall, d.sc)
                z2 <- abs(1-d.sc) * crop(rlarge, d.sc)

      # merge rasters
                m <- merge(z1 + z2, rsmall, rlarge, filename=filename, ...)
        } else {    # the overlapping case

                # create points around ovelapping area
                a <- crop(x, j)
                a <- setValues(a, 1)
                b <- crop(y, j)
                b <- setValues(b, 2)
                ab <- merge(a, b)
                ba <- merge(b, a)
                p1 <- rasterToPoints(ab, function(x) x==2)
                p2 <- rasterToPoints(ba, function(x) x==1)

      # calculate distances to points in overlapping area
                d1 <- distanceFromPoints(i, p1[,1:2])
                d2 <- distanceFromPoints(i, p2[,1:2])

      # the logistic case
                if(logistic){
                        d1min <- cellStats(d1,'min')
                        d2min <- cellStats(d2,'min')
                        d1 <- logfun((d1 - d1min + 1e-9)/(cellStats(d1,'max') - d1min))
                        d2 <- logfun((d2 - d2min + 1e-9)/(cellStats(d2,'max') - d2min))
                }       

      # sum distance rasters
                dsum <- d1 + d2

      # create distance weighted rasters
                z1 <- d1 * crop(x, d1) / dsum
                z2 <- d2 * crop(y, d2) / dsum
                z <- sum(z1, z2)

      # merge rasters
                m <- merge(z, x, y, filename=filename, ...)
   }

   m
}

29 blockSize.R

# Author: Robert J. Hijmans
# Date : November 2009
# Version 0.9
# Licence GPL v3
blockSize <- function(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) {
        n <- max(n, 1)
        if (missing(chunksize)) {
                bs <- .chunksize()  / n
        } else {
                bs <- chunksize
        }

        blockrows <- try(slot(x@file, 'blockrows'), silent=TRUE)
        if (class(blockrows) == 'try-error') {
                blockrows <- 1
        }
        blockrows <- max(blockrows, 1)


        nr <- nrow(x)
        size <- min(nr, max(1, floor(bs / ncol(x))))
        # min number of chunks
        if (size > 1) {
                minblocks <- min(nr, max(1, minblocks))
                size <- min(ceiling(nr/minblocks), size)
        }
        size <- min(max(size, minrows), nr)
        size <- max(minrows, blockrows * round(size / blockrows))

        nb <- ceiling(nr / size)
        row <- (0:(nb-1))*size + 1
        nrows <- rep(size, length(row))
        dif = nb * size - nr
        nrows[length(nrows)] = nrows[length(nrows)] - dif

        return(list(row=row, nrows=nrows, n=nb))
}

30 boundaries.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
# name overlap with igraph
edge <- function(x, ...) {
        warning('edge is obsolete and will be removed from this package. Use the boundaries function instead')
        boundaries(x, ...)
        warning('edge is obsolete and will be removed from this package. Use the boundaries function instead')
}
if (!isGeneric(boundaries)) {
        setGeneric(boundaries, function(x, ...)
                standardGeneric(boundaries))
}       
setMethod('boundaries', signature(x='RasterLayer'), 
function(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename=, ...) {
        stopifnot( nlayers(x) == 1 )
        stopifnot( hasValues(x) )
        filename <- trim(filename)

        out <- raster(x)
        gll <- as.integer( .isGlobalLonLat(out) )
        type <- tolower(type)
        if (! type %in% c('inner', 'outer')) {
                stop(type must be 'inner', or 'outer')
        }

        if (type=='inner') { 
                type <- as.integer(0) 
        } else { 
                type <- as.integer(1) 
        }
        classes <- as.integer(as.logical(classes))
        directions <- as.integer(directions)
        stopifnot(directions %in% c(4,8))


#       asZero <- as.integer(as.logical(asZero))


        datatype <- list(...)$datatype
        if (is.null(datatype)) {
                datatype <- 'INT2S'
        }

        if (canProcessInMemory(out, 4)) {
                x <- as.matrix(x)
                if (gll) {
                        x <- cbind(x[, ncol(x)], x, x[, 1]) 
                } else {
                        x <- cbind(x[, 1], x, x[, ncol(x)]) 
                }
                x <- rbind(x[1,], x, x[nrow(x),])
                paddim <- as.integer(dim(x))
                x <- .Call('edge', as.integer(t(x)), paddim, classes, type, directions, NAOK=TRUE, PACKAGE='raster')
                if (asNA) {
                        x[x==0] <- as.integer(NA)
                }
                x <- matrix(x, nrow=paddim[1], ncol=paddim[2], byrow=TRUE)
                x <- x[2:(nrow(x)-1), 2:(ncol(x)-1)]
                x <- setValues(out, as.vector(t(x)))
                if (filename  != '') {
                        x <- writeRaster(x, filename, datatype=datatype, ...)
                }
                return(x)
        } else {

                out <- writeStart(out, filename, datatype=datatype, ...)
                tr <- blockSize(out, minblocks=3, minrows=3)
                pb <- pbCreate(tr$n, label='boundaries', ...)

                nc <- ncol(out)+2
                v <- getValues(x, row=1, nrows=tr$nrows[1]+1)
                v <- matrix(v, ncol=tr$nrows[1]+1)
                if (gll) {
                        v <- rbind(v[nrow(v),], v, v[1,])
                } else {
                        v <- rbind(v[1,], v, v[nrow(v),])
                }
                v <- as.integer(cbind(v[,1], v))

                v <- .Call('edge', v, as.integer(c(tr$nrows[1]+2, nc)),  classes, type, directions, NAOK=TRUE, PACKAGE='raster')
                if (asNA) {
                        v[v==0] <- as.integer(NA)
                }
                v <- matrix(v, ncol=nc, byrow=TRUE)
                v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)]))
                out <- writeValues(out, v, 1)
                pbStep(pb, 1)
                for (i in 2:(tr$n-1)) {
                        v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2)
                        v <- matrix(v, ncol=tr$nrows[1]+2)
                        if (gll) {
                                v <- rbind(v[nrow(v),], v, v[1,])
                        } else {
                                v <- rbind(v[1,], v, v[nrow(v),])
                        }
                        v <- .Call('edge', as.integer(v), as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster')
                        v <- matrix(v, ncol=nc, byrow=TRUE)
                        v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)]))
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                i <- tr$n
                v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1)
                v <- matrix(v, ncol=tr$nrows[i]+1)
                if (gll) {
                        v <- rbind(v[nrow(v),], v, v[1,])
                } else {
                        v <- rbind(v[1,], v, v[nrow(v),])
                }
                v <- as.integer(cbind(v, v[,ncol(v)]))
                v <- .Call('edge', v, as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster')
                v <- matrix(v, ncol=nc, byrow=TRUE)
                v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)]))
                out <- writeValues(out, v, tr$row[i])
                pbStep(pb, tr$n)
                out <- writeStop(out)
                pbClose(pb)
        }
        return(out)
}
)

31 boxplot.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com 
# Date :  November 2010
# Version 1.0
# Licence GPL v3

if (!isGeneric(boxplot)) {
        setGeneric(boxplot, function(x, ...)
                standardGeneric(boxplot))
}
setMethod('boxplot', signature(x='RasterStackBrick'), 
        function(x, maxpixels=100000, ...) {
                nl <- nlayers(x)
                cn <- names(x)
                if ( canProcessInMemory(x)) {
                        x <- getValues(x)
                } else {
                        warning('taking a sample of ', maxpixels, ' cells')
                        x = sampleRegular(x, maxpixels, useGDAL=TRUE)
                }       
                colnames(x) <- cn
                boxplot(x, ...)
        }
)
setMethod('boxplot', signature(x='RasterLayer'), 
        function(x, y=NULL, maxpixels=100000, ...) {
                if (is.null(y)) {
                        cn <- names(x)
                        if ( canProcessInMemory(x)) {
                                x <- getValues(x)
                        } else {
                                warning('taking a sample of ', maxpixels, ' cells')
                                x = sampleRegular(x, maxpixels, useGDAL=TRUE)
                        }       
                        x <- matrix(x)
                        colnames(x) <- cn
                        boxplot(x, ...)
                } else {
                        s <- stack(x,y)
                        if ( canProcessInMemory(x)) {
                                s <- getValues(s)
                        } else {
                                warning('taking a sample of ', maxpixels, ' cells')
                                s <- sampleRegular(s, maxpixels, useGDAL=TRUE)
                        }       
                        cn <- colnames(s)
                        f <- as.formula(paste(cn[1], '~', cn[2]))
                        boxplot(f, data=x, ...)
                }       
        }
)

32 brick.R

# Author: Robert J. Hijmans
# Date :  September 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(brick)) {
        setGeneric(brick, function(x, ...)
                standardGeneric(brick))
}       
setMethod('brick', signature(x='missing'), 
        function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) {
                e <- extent(xmn, xmx, ymn, ymx)
                if (missing(crs)) {
                        if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { 
                                crs =+proj=longlat +datum=WGS84
                        } else {
                                crs=NA
                        }
                }
                b <- brick(e, nrows=nrows, ncols=ncols, crs=crs, nl=nl)
                return(b)
        }
)
setMethod('brick', signature(x='character'), 
        function(x, ...) {
                .rasterObjectFromFile(x, objecttype='RasterBrick', ...)
        }
)
setMethod('brick', signature(x='RasterLayer'), 
        function(x, ..., values=TRUE, nl=1, filename='') {
                nl <- max(round(nl), 0)
                if (!hasValues(x)) {
                        values <- FALSE
                }

                if (!values) {
                        b <- brick(x@extent, nrows=nrow(x), ncols=ncol(x), crs=projection(x), nl=nl)
                        if (rotated(x)) {
                                b@rotated <- TRUE
                                b@rotation <- x@rotation
                        }
                        return(b)
                }

                filename <- trim(filename)
                dots <- list(...)
                if (is.null(dots$format)) { format <- .filetype(filename=filename) } 
                if (is.null(dots$datatype)) { datatype <- .datatype() }
                if (is.null(dots$overwrite)) { overwrite <- .overwrite() }
                if (is.null(dots$progress)) { progress <- .progress() }
                x <- stack(x, ...)

                brick(x, values=values, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress)
        }
)
setMethod('brick', signature(x='RasterStack'), 
        function(x, values=TRUE, nl, filename='', ...){

                e <- x@extent
                b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=projection(x))
                if (rotated(x)) {
                        b@rotated <- TRUE
                        b@rotation <- x@rotation
                }
                if (missing(nl)) {
                        nl <- nlayers(x) 
                        if (nl < 1) {
                                values <- FALSE
                        }
                } else {
                        nl <- max(round(nl), 0)
                        values <- FALSE
                }

                b@data@nlayers <- as.integer(nl)

                filename <- trim(filename)

                if (values) {

                        b@data@names <- names(x)[1:nl]
                        if (canProcessInMemory(b, nl*2)) {
                                b <- setValues( b, getValues(x)[,1:nl]) 
                                if (any(is.factor(x))) {
                                        b@data@isfactor <- is.factor(x)
                                        b@data@attributes <- levels(x)
                                }
                                if (filename != '') {
                                        b <- writeRaster(b, filename, ...)
                                }
                                return(b)

                        } else {
                                b <- writeStart(b, filename=filename, ...)
                                tr <- blockSize(b)
                                pb <- pbCreate(tr$n, ...)                       
                                x <- readStart(x)
                                for (i in 1:tr$n) {
                                        vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                        b <- writeValues(b, vv, tr$row[i])
                                        pbStep(pb, i)
                                }
                                pbClose(pb)
                                b <- writeStop(b)
                                x <- readStop(x)
                                return(b)
                        }

                } else {
                        b@data@min <- rep(Inf, b@data@nlayers)
                        b@data@max <- rep(-Inf, b@data@nlayers)
                        return(b)
                }
        }
)
setMethod('brick', signature(x='RasterBrick'), 
        function(x, nl, ...){
                if (missing(nl)) { 
                        nl <- nlayers(x) 
                }
                e <- x@extent
                b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=projection(x))
                b@data@nlayers <- as.integer(nl)
                b@data@min <- rep(Inf, nl)
                b@data@max <- rep(-Inf, nl)
                if (rotated(x)) {
                        b@rotated <- TRUE
                        b@rotation <- x@rotation
                }
                return(b)
        }
)
setMethod('brick', signature(x='Extent'), 
        function(x, nrows=10, ncols=10, crs=NA, nl=1) {
                bb <- extent(x)
                nr = as.integer(round(nrows))
                nc = as.integer(round(ncols))
                if (nc < 1) { stop(ncols should be > 0) }
                if (nr < 1) { stop(nrows should be > 0) }
                b <- new(RasterBrick, extent=bb, ncols=nc, nrows=nr)
                projection(b) <- crs
                nl <- max(round(nl), 0)
                b@data@nlayers <- as.integer(nl)
                b@data@isfactor <- rep(FALSE, nl)
                return(b) 
        }
)
setMethod('brick', signature(x='SpatialGrid'), 
        function(x){
                b <- brick()
                extent(b) <- extent(x)
                projection(b) <- x@proj4string
                dim(b) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1])   

                if (class(x) == 'SpatialGridDataFrame') {

                        x <- x@data

                        b@data@isfactor <- rep(FALSE, ncol(x))

                        isfact <- sapply(x, function(i) is.factor(i) | is.character(i))
                        b@data@isfactor <- isfact
                        if (any(isfact)) {
                                for (i in which(isfact)) {
                                        rat <- data.frame(table(x[[i]]))
                                        rat <- data.frame(1:nrow(rat), rat[,2], rat[,1])
                                        colnames(rat) <- c(ID, COUNT, colnames(x)[i])
                                        b@data@attributes[[i]] <- rat
                                        x[,i] <- as.integer(x[,i])
                                }
                        }

                        b <- setValues(b, as.matrix(x))
                        b@data@names <- colnames(x)
                }
                return(b)
        }       
)
setMethod('brick', signature(x='SpatialPixels'), 
        function(x) {
                if (inherits( x, 'SpatialPixelsDataFrame')) {
                        x <- as(x, 'SpatialGridDataFrame')
                } else {        
                        x <- as(x, 'SpatialGrid')
                }
                return(brick(x))
        }
)

setMethod('brick', signature(x='array'), 
        function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, transpose=FALSE) {
                dm <- dim(x)
                if (is.matrix(x)) {
                        stop('cannot coerce a matrix to a RasterBrick')
                }
                if (length(dm) != 3) {
                        stop('array has wrong number of dimensions (needs to be 3)')
                }
                b <- brick(xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs, nl=dm[3])
                names(b) <- dimnames(x)[[3]]

                if (transpose) {
                        dim(b) <- c(dm[2], dm[1], dm[3])
                } else {
                        dim(b) <- dm
                        # aperm etc suggested by Justin McGrath
                        # https://r-forge.r-project.org/forum/message.php?msg_id=4312
                        x = aperm(x, perm=c(2,1,3))
                }
                attributes(x) <- list()
                dim(x) <- c(dm[1] * dm[2], dm[3])
                setValues(b, x)
        }
)

setMethod('brick', signature(x='big.matrix'), 
        function(x, template, filename='', ...) {
                stopifnot(inherits(template, 'BasicRaster'))
                stopifnot(nrow(x) == ncell(template))
                r <- brick(template)
                filename <- trim(filename)
                names(r) <- colnames(x)
                if (canProcessInMemory(r)) {
                        r <- setValues(r, x[])
                        if (filename != '') {
                                r <- writeRaster(r, filename, ...)
                        }
                } else {
                        tr <- blockSize(r)
                        pb <- pbCreate(tr$n, ...)
                        r <- writeStart(r, filename, ...)
                        for (i in 1:tr$n) {
                                r <- writeValues(r, x[tr$row[i]:(tr$row[i]+tr$nrows[i]-1), ], tr$row[i] )
                                pbStep(pb) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                }
                return(r)
        }
)


setMethod('brick', signature(x='kasc'), 
        function(x) {
                as(x, 'RasterBrick')
        }
)
setMethod('brick', signature(x='grf'), 
        function(x) {
                as(x, 'RasterBrick')
        }
)
setMethod('brick', signature(x='list'), 
        function(x) {
                x <- stack(x)
                brick(x)
        }
)

33 buffer.R

# Author: Robert J. Hijmans
# Date : September 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric('buffer')) {
        setGeneric('buffer', function(x, ...)
                standardGeneric('buffer'))
}       
setMethod('buffer', signature(x='RasterLayer'), 
function(x, width=0, filename='', doEdge=FALSE, ...) {
        stopifnot(width > 0)
        if (doEdge) {
                r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) 
                pts <- try(  rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] )
        } else {
                pts <- try(  rasterToPoints(x)[,1:2, drop=FALSE] )
        }

        if (class(pts) == try-error) {
                return( .distanceRows(x, filename=filename, ...) )
        }
        if (nrow(pts) == 0) {
                stop('RasterLayer has no NA cells (for which to compute a distance)')
        }
        out <- raster(x)
        filename <- trim(filename)

        if (couldBeLonLat(x)) { 
                longlat=TRUE 
        } else { 
                longlat=FALSE 
        }

        if (canProcessInMemory(out, 6)) {
                pb <- pbCreate(4, label='buffer', ...)
                x <- values(x)
                i <- which(is.na(x))
                if (length(i) < 1) {
                        stop('raster has no NA values to compute distance to')
                }
                pbStep(pb)
                x[] <- 0
                xy <- xyFromCell(out, i)
                x[i] <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster')
                pbStep(pb)
                x[x > width] <- NA
                x[!is.na(x)] <- 1
                pbStep(pb)
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename=filename, ...)
                }
                pbStep(pb)
                pbClose(pb)
                return(out)
        } 

        out <- writeStart(out, filename=filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='buffer', ...)
        xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA)
        for (i in 1:tr$n) {
                if (i == tr$n) {
                        xy <- xy[1:(ncol(out)*tr$nrows[i]), ]
                }
                xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out))
                vals <- getValues(x, tr$row[i], tr$nrows[i])
                j <- which(is.na(vals))
                vals[] <- 0
                if (length(j) > 0) {
                        vals[j] <- .Call(distanceToNearestPoint, xy[j,,drop=FALSE], pts, as.integer(longlat), PACKAGE='raster')
                }
                vals[vals > width] <- NA
                vals[!is.na(vals)] <- 1
                out <- writeValues(out, vals, tr$row[i])
                pbStep(pb)      
        }       
        pbClose(pb)
        out <- writeStop(out)
        return(out)
}
)

34 calc.R

# Author: Robert J. Hijmans & Matteo Mattiuzzi
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(calc)) {
        setGeneric(calc, function(x, fun, ...)
                standardGeneric(calc))
}       
.makeTextFun <- function(fun) {
        if (class(fun) != 'character') {
                if (is.primitive(fun)) {
                        test <- try(deparse(fun)[[1]], silent=TRUE)
                        if (test == '.Primitive(\sum\)') { fun <- 'sum' 
                        } else if (test == '.Primitive(\min\)') { fun <- 'min' 
                        } else if (test == '.Primitive(\max\)') { fun <- 'max' 
                        }
                } else {
                        test1 <- isTRUE(try( deparse(fun)[2] == 'UseMethod(\mean\)', silent=TRUE))
                        test2 <- isTRUE(try( fun@generic == 'mean', silent=TRUE))
                        if (test1 | test2) { 
                                fun <- 'mean' 
                        }
                } 
        }
        return(fun)
}
.getRowFun <- function(fun) {
        if (fun == 'mean') { return(rowMeans)
        } else if (fun == 'sum') { return(rowSums)
        } else if (fun == 'min') { return(.rowMin)
        } else if (fun == 'max') { return(.rowMax)
        } else { stop('unknown fun') }
}
.getColFun <- function(fun) {
        if (fun == 'mean') { return(colMeans)
        } else if (fun == 'sum') { return(colSums)
        } else if (fun == 'min') { return(.colMin)
        } else if (fun == 'max') { return(.colMax)
        } else { stop('unknown fun') }
}
.calcTest <- function(tstdat, fun, na.rm, forcefun=FALSE, forceapply=FALSE) {

        if (forcefun & forceapply) {
                forcefun <- FALSE
                forceapply <- FALSE
        }

        trans <- FALSE
        doapply <- FALSE
        makemat <- FALSE

        nl <- NCOL(tstdat)

        if (nl == 1) {
        # the main difference with nl > 1 is that
        # it is important to avoid using apply when a normal fun( ) call will do. 
        # that is a MAJOR time saver. But in the case of a RasterStackBrick it is more
        # natural to try apply first.   
                if (forceapply) {
                        doapply <- TRUE
                        makemat <- TRUE 
                        tstdat <- matrix(tstdat, ncol=1)
                        if (missing(na.rm)) {
                                test <- try( apply(tstdat, 1, fun), silent=TRUE)
                        } else {
                                test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE)
                        }
                        if (length(test) < length(tstdat) | class(test) == 'try-error') {
                                stop('cannot forceapply this function')
                        }
                        if (is.matrix(test)) {
                                if (ncol(test) > 1) {
                                        trans <- TRUE
                                }
                        }
                } else {
                        if (! missing(na.rm)) {
                                test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE)
                                if (class(test) == 'try-error') {
                                        test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE)
                                        doapply <- TRUE
                                        if (class(test) == 'try-error') {
                                                stop(cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?) 
                                        } 
                                        if (is.matrix(test)) {
                                                if (ncol(test) > 1) {
                                                        trans <- TRUE
                                                }
                                        }
                                }
                        } else {
                                test <- try(fun(tstdat), silent=TRUE)
                                if (length(test) < length(tstdat) | class(test) == 'try-error') {
                                        doapply <- TRUE
                                        makemat <- TRUE 
                                        tstdat <- matrix(tstdat, ncol=1)                                        
                                        test <- try( apply(tstdat, 1, fun), silent=TRUE)
                                        if (class(test) == 'try-error') {
                                                stop(cannot use this function)
                                        }
                                        if (is.matrix(test)) {
                                                if (ncol(test) > 1) {
                                                        trans <- TRUE
                                                }
                                        }
                                }
                        }
                }
        } else {

                if (forcefun) {
                        doapply <- FALSE
                        test  <- fun(tstdat)
                } else {
                        doapply <- TRUE
                        if (! missing(na.rm)) {
                                test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE)
                                if (class(test) == 'try-error') {
                                        doapply <- FALSE
                                        test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE)
                                        if (class(test) == 'try-error') {
                                                stop(cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?) 
                                        }
                                } else if (is.matrix(test)) {
                                        trans <- TRUE
                                }
                        } else {
                                test <- try( apply(tstdat, 1, fun), silent=TRUE)
                                if (class(test) == 'try-error') {
                                        doapply <- FALSE
                                        test <- try(fun(tstdat), silent=TRUE)
                                        if (class(test) == 'try-error') {
                                                stop(cannot use this function) 
                                        }
                                } else if (is.matrix(test)) {
                                        trans <- TRUE
                                }
                        }
                }
        }       

        if (trans) {
                test <- t(test)
                test <- ncol(test)
        } else {
                test <- length(test) / 5
        }
        nlout <- as.integer(test)
        list(doapply=doapply, makemat=makemat, trans=trans, nlout=nlout)
}
#.calcTest(test[1:5], fun, forceapply=T)
setMethod('calc', signature(x='Raster', fun='function'), 
function(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) {
        nl <- nlayers(x)
        test <- .calcTest(x[1:5], fun, na.rm, forcefun, forceapply)
        doapply <- test$doapply
        makemat <- test$makemat
        trans <- test$trans
        if (test$nlout == 1) {
                out <- raster(x)
        } else {
                out <- brick(x, values=FALSE)
                out@data@nlayers <- test$nlout
        }
        fun <- .makeTextFun(fun)
        if (class(fun) == 'character') { 
                doapply <- FALSE
                fun <- .getRowFun(fun)
        } 

        filename <- trim(filename)
        if (canProcessInMemory(x, max(nlayers(x), nlayers(out)) * 2)) {
                x <- getValues(x)
                if (makemat) { 
                        x <- matrix(x, ncol=1) 
                }
                if (missing(na.rm)) {
                        if (! doapply ) { 
                                x <- fun(x ) 
                        } else {
                                x <- apply(x, 1, fun )
                        }
                } else {
                        if ( ! doapply ) { 
                                x <- fun(x, na.rm=na.rm ) 
                        } else {
                                x <- apply(x, 1, fun, na.rm=na.rm)
                        }
                }
                if (trans) {
                        x <- t(x)
                }
                x <- setValues(out, x)
                if (filename != '') {
                        x <- writeRaster(x, filename, ...)
                }
                return(x)               
        }
# else 

        x <- readStart(x)
        out <- writeStart(out, filename=filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='calc', ...)                 
        if (missing(na.rm)) {
                for (i in 1:tr$n) {
                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        if ( ! doapply ) {
                                v <- fun(v)
                        } else {
                                if (makemat) { 
                                        v <- matrix(v, ncol=1) 
                                }
                                v <- apply(v, 1, fun)
                                if (trans) {
                                        v <- t(v)
                                }
                        }
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb) 
                }
        } else {
                for (i in 1:tr$n) {
                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        if ( ! doapply ) {
                                v <- fun(v, na.rm=na.rm)
                        } else {
                                if (makemat) { 
                                        v <- matrix(v, ncol=1) 
                                }
                                v <- apply(v, 1, fun, na.rm=na.rm)
                                if (trans) {
                                        v <- t(v)
                                }
                        }
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb) 
                }
        }
        out <- writeStop(out)
        x <- readStop(x)
        pbClose(pb)
        return(out)
}
)

35 canProcessInMemory.R

# Authors: Robert J. Hijmans
# Date :  January 2009
# Version 0.9
# Licence GPL v3
canProcessInMemory <- function(x, n=4) {
# for testing purposes  
#       rasterOptions(format='GTiff') 
#       require(ncdf)
#       require(rgdal)
#       rasterOptions(format='big.matrix')
#       rasterOptions(format='CDF')
#       rasterOptions(overwrite=TRUE)
#  rasterOptions(todisk=TRUE)
#  return(FALSE)

        if (.toDisk()) { 
                return(FALSE) 
        } 

        n <- n + nlayers(x) - 1
        cells <- round( 1.1 * ncell(x) ) * n
        if ( cells > .maxmemory() ) {
                return(FALSE) 
        } else {
                return(TRUE)
        }
}
#       if (cells > .maxmemory()) {
#               return(FALSE) 
#       } else if ( cells < 1000000 ) {
#               return(TRUE)
#       } else {
#               return(TRUE)
#       }


#       if (substr( R.Version()$platform, 1, 7) == i386-pc ) {
#       # windows, function memory.size  available
#       memneed <- cells * 8 * n / (1024 * 1024)
#       memavail <- 0.5 * (memory.size(NA)-memory.size(FALSE))
#       if (memneed > memavail) {
#               return(FALSE)
#       } else {
#               return(TRUE)
#       }
#   } else {
#       g <- gc()
#  if (.Platform$OS.type == unix){
## Memory in KB, from: http://stackoverflow.com/questions/2441046/how-to-get-physical-memory-in-bash
#       mem <- as.numeric(system(grep MemTotal /proc/meminfo | awk '{print $2}',intern=TRUE))
#       w <- getOption('warn')
#       on.exit(options('warn'= w))
#       options('warn'=-1) 
#       r <- try( matrix(0.1, ncol=n, nrow=cells), silent=TRUE )
#       if (class(r) == try-error) {
#               return( FALSE )
#               g <- gc()
#               return( TRUE ) 
#       }

36 cellFromLine.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : December 2009
# Version 0.9
# Licence GPL v3
cellFromLine <- function(object, lns) {
        spbb <- bbox(lns)
        rsbb <- bbox(object)
        addres <- 2 * max(res(object))
        nlns <- length( lns@lines )
        res <- list()
        res[[nlns+1]] = NA
        if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) {
                return(res[1:nlns])
        }

        rr <- raster(object)
        for (i in 1:nlns) {
                pp <- lns[i,]
                spbb <- bbox(pp)

                if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) {
                        rc <- crop(rr, extent(pp)+addres)
                        rc <- .linesToRaster(pp, rc, silent=TRUE)
                        xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                        if (length(xy) > 0) { # always TRUE?
                                res[[i]] <- cellFromXY(object, xy)
                        } 
                }
        }
        return( res[1:nlns] )
}

37 cellFromPolygon.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : January 2011
# Version 1.0
# Licence GPL v3
cellFromPolygon <- function(object, p, weights=FALSE) {
        spbb <- bbox(p)
        rsbb <- bbox(object)
        addres <- max(res(object))
        npol <- length(p@polygons)
        res <- list()
        res[[npol+1]] = NA
        if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) {
                return(res[1:npol])
        }
        rr <- raster(object)
        for (i in 1:npol) {
                pp <- p[i,]
                spbb <- bbox(pp)

                if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) {
                        # do nothing; res[[i]] <- NULL
                } else {
                        rc <- crop(rr, extent(pp)+addres)
                        if (weights) {
                                rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE)
                                rc[rc==0] <- NA
                                xy <- rasterToPoints(rc)
                                weight <- xy[,3] / 100
                                xy <- xy[,-3]
                        } else {
                                rc <- .polygonsToRaster(pp, rc, silent=TRUE)
                                xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                        }

                        if (length(xy) > 0)  {  # catch holes or very small polygons
                                cell <- cellFromXY(object, xy)
                                if (weights) {
                                        res[[i]] <- cbind(cell, weight)
                                } else {
                                        res[[i]] <- cell
                                }
                        } 
                }
        }

        return( res[1:npol] )
}

38 cellRowCol.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 0.9
# Licence GPL v3

rowFromCell <- function(object, cell) {
        object <- raster(object)
        cell <- round(cell)
        cell[cell < 1 | cell > ncell(object)] <- NA
        trunc((cell-1)/ncol(object)) + 1
}
.rowFromCell <- function(object, cell) {
        trunc((cell-1)/ncol(object)) + 1
}
cellFromRow <- function(object, rownr) {
        object <- raster(object)
        rownr <- round(rownr)
        if (length(rownr)==1) {
                return(cellFromRowCol(object, rownr, 1):cellFromRowCol(object, rownr, object@ncols))
        }
        cols <- rep(1:ncol(object), times=length(rownr))
        rows <- rep(rownr, each=ncol(object))   
        cellFromRowCol(object, rows, cols)
}
cellFromCol <- function(object, colnr) {
        object <- raster(object)
        colnr <- round(colnr)
        rows <- rep(1:nrow(object), times=length(colnr))
        cols <- rep(colnr, each=nrow(object))
        return(cellFromRowCol(object, rows, cols))
}
.OLD_cellFromRowColCombine <- function(object, rownr, colnr) {
        object <- raster(object)
        rc <- expand.grid(rownr, colnr)
        return( cellFromRowCol(object, rc[,1], rc[,2]))
}
cellFromRowColCombine <- function(object, rownr, colnr) {
        object <- raster(object)
        rownr[rownr < 1 | rownr > object@nrows] <- NA
        colnr[colnr < 1 | colnr > object@ncols] <- NA
        cols <- rep(colnr, times=length(rownr))
        dim(cols) <- c(length(colnr), length(rownr))
        cols <- t(cols)
        rownr <- (rownr-1) * object@ncols
        cols <- cols + rownr
        as.vector(t(cols))
}
colFromCell <- function(object, cell) {
        object <- raster(object)
        cell <- round(cell)
        cell[cell < 1 | cell > ncell(object)] <- NA     
        rownr <- trunc((cell-1)/object@ncols) + 1
        as.integer(cell - ((rownr-1) * object@ncols))
}
.colFromCell <- function(object, cell) {
        nc <- object@ncols
        rownr <- trunc((cell-1)/nc) + 1
        cell - ((rownr-1) * nc)
}
rowColFromCell <- function(object, cell) {
        object <- raster(object)
        cell <- round(cell)
        cell[cell < 1 | cell > ncell(object)] <- NA
        row <- as.integer(trunc((cell-1)/object@ncols) + 1)
        col <- as.integer(cell - ((row-1) * object@ncols))
        return(cbind(row, col))
}
cellFromRowCol <- function(object, rownr, colnr) {
        object <- raster(object)
        rownr <- round(rownr)
        colnr <- round(colnr)
        rownr[rownr < 1 | rownr > nrow(object)] <- NA
        colnr[colnr < 1 | colnr > ncol(object)] <- NA   
        # recycle if length(rownr) != length(colnr)
        x <- cbind(rownr, colnr)
        as.vector((x[,1]-1) * ncol(object) + x[,2])
}

39 cellsFromExtent.R

# R function for the raster package
# Author: Robert J. Hijmans
# contact: r.hijmans@gmail.com
# Date : January 2009
# Version 0.9
# Licence GPL v3
cellsFromExtent <- function(object, extent, expand=FALSE) {
        object <- raster(object) 
        extent <- alignExtent(extent(extent), object)
        innerBox <- intersect(extent(object), extent)
        if (is.null(innerBox)) { 
                return(NULL) 
        }

        srow <- rowFromY(object, innerBox@ymax - 0.5 * yres(object))
        erow <- rowFromY(object, innerBox@ymin + 0.5 * yres(object))
        scol <- colFromX(object, innerBox@xmin + 0.5 * xres(object))
        ecol <- colFromX(object, innerBox@xmax - 0.5 * xres(object))

        if (expand) {
                srow <- srow - round((extent@ymax - innerBox@ymax) / yres(object))
                erow <- erow + round((innerBox@ymin - extent@ymin) / yres(object))
                scol <- scol - round((innerBox@xmin - extent@xmin) / xres(object))
                ecol <- ecol + round((extent@xmax - innerBox@xmax) / xres(object))
        }
        return(cellFromRowColCombine(object, srow:erow, scol:ecol))
}

40 cellStats.R

# Author: Robert J. Hijmans
# Date : March 2009 / April 2012
# Version 1.0
# Licence GPL v3
.csTextFun <- function(fun) {
        if (class(fun) != 'character') {
                if (is.primitive(fun)) {
                        test <- try(deparse(fun)[[1]], silent=TRUE)
                        if (test == '.Primitive(\sum\)') { fun <- 'sum' 
                        } else if (test == '.Primitive(\min\)') { fun <- 'min' 
                        } else if (test == '.Primitive(\max\)') { fun <- 'max' 
                        }
                } else {
                        f <- paste(deparse(fun), collapse = \n)
                        if (f == paste(deparse(mean), collapse = \n)) {
                                fun <- 'mean' 
                        } else if (f == paste(deparse(sd), collapse = \n)) {
                                fun <- 'sd' 
                        } else if (f == paste(deparse(range), collapse = \n)) {
                                fun <- 'range' 
                        }                       
                } 
        }
        return(fun)
}

if (!isGeneric(cellStats)) {
        setGeneric(cellStats, function(x, stat, ...)
                standardGeneric(cellStats))
}       
setMethod('cellStats', signature(x='RasterStackBrick'),
        function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) {

                stopifnot(hasValues(x))
                makeMat <- FALSE
                if (nlayers(x) == 1) {  
                        makeMat <- TRUE
                        #return( cellStats(raster(x, values=TRUE, stat=stat, ...) )             
                }

                stat <- .csTextFun(stat)

                if (!inMemory(x)) {
                        if (canProcessInMemory(x)) {
                                x <- readAll(x)
                        }
                }
                if (inMemory(x) ) {
                        x <- getValues(x)
                        if (makeMat) {
                                x <- matrix(x, ncol=1)
                        }
                        if (class(stat) == 'character') {
                                if (stat == mean ) {
                                        return( colMeans(x, na.rm=na.rm) )

                                } else if (stat == sum ) {
                                        return( colSums(x, na.rm=na.rm) )
                                } else if (stat == min ) {
                                        v <- .colMin(x, na.rm=na.rm) 
                                        names(v) <- names(x)
                                        return(v)
                                } else if (stat == max ) {
                                        v <- .colMax(x, na.rm=na.rm)
                                        names(v) <- names(x)
                                        return(v)

                                } else if (stat == 'countNA') { 
                                        warning ('countNA' is deprecated. Use freq(x, 'value=NA') instead)
                                        return( colSums(is.na(x)) )

                                } else if (stat == 'sd') { 

                                        st <- apply(x, 2, sd, na.rm=na.rm) 
                                        if (! asSample) {
                                                if (na.rm) {
                                                        n <- colSums(! is.na(x))
                                                } else {
                                                        n <- nrow(x)
                                                }
                                                st <- sqrt(st^2 * (n/(n-1)))
                                        } 
                                        return(st)
                                } else if (stat == 'rms') { 
                                        if (na.rm) {
                                                n <- colSums(! is.na(x))
                                        } else {
                                                n <- nrow(x)
                                        }
                                        if (asSample) {
                                                n <- n-1
                                        }
                                        # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n))
                                        return(  sqrt( apply(x, 2, function(x) sum(x^2))/n ) )

                                } else if (stat == 'skew') { 
                                        if (na.rm) {
                                                n <- colSums(! is.na(x))
                                        } else {
                                                n <- nrow(x)
                                        }
                                        if (asSample) {
                                                sdx <- apply(x, 2, sd, na.rm=na.rm)
                                        } else {
                                                sdx <- apply(x, 2, function(x) sqrt(sum((x-mean(x, na.rm=na.rm))^2, na.rm=na.rm)/n))
                                        }
                                        return(  colSums(t(t(x) - colMeans(x, na.rm=na.rm))^3, na.rm=na.rm) / (n * sdx^3) )
                                }
                        } # else 

                        return(apply(x, 2, stat, na.rm=na.rm, ...))
                }

                if (class(stat) != 'character') {
                        stop('cannot use this function for large files')
                }

                st <- NULL
                counts <- FALSE
                if (stat == 'sum') {
                        fun <- sum
                        st <- 0 
                } else if (stat == 'min') {
                        st <- Inf
                } else if (stat == 'max') {
                        st <- -Inf
                } else if (stat == 'range') {
                        fun <- range
                } else if (stat == 'countNA') {
                        warning ('countNA' is depracted. Use freq(x, 'value=NA') instead)
                        st <- 0 
                        counts <- TRUE
                } else if (stat == 'skew') {

                        zmean <- cellStats(x, 'mean')
                        cnt <- 0
                        d3 <- 0
                        sumsq <- 0
                        counts <- TRUE

                } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') {
                        st <- 0 
                        sumsq <- 0
                        cnt <- 0
                        counts <- TRUE

                } else { 
                        stop(invalid 'stat'. Should be 'sum', 'min', 'max', 'sd', 'mean', 'rms', or 'skew') 
                }

                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='cellStats', ...)

                for (i in 1:tr$n) {
                        d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        if (makeMat) {
                                d <- matrix(d, ncol=1)
                        }
                        if (counts) {
                                if (na.rm & stat != 'countNA') {
                                        nas <- colSums( is.na(d) )
                                        if (min(nas) == nrow(d)) { 
                                                next 
                                        }
                                        cells <- nrow(d) - nas
                                } else {
                                        if (stat == 'countNA') {
                                                nas <- colSums( is.na(d) )
                                        } else {
                                                cells <- nrow(d)
                                        }
                                }
                        }

                        if (stat=='mean') {
                                st <- colSums(d, na.rm=na.rm) + st
                                cnt <- cnt + cells

                        } else if (stat=='sum') {
                                st <- colSums(d, na.rm=na.rm) + st
                        } else if (stat == 'sd') {
                                st <- colSums(d, na.rm=na.rm) + st
                                cnt <- cnt + cells
                                sumsq <- colSums(d^2, na.rm=na.rm) + sumsq
                        } else if (stat=='countNA') {
                                st <- st + nas

                        } else if (stat=='rms') {

                                sumsq <- colSums(d^2, na.rm=TRUE) + sumsq
                                cnt <- cnt + cells
                        } else if (stat=='skew') {
                                d <- t( t(d) - zmean )
                                sumsq <- colSums(d^2, na.rm=TRUE) + sumsq
                                d3 <- colSums(d^3, na.rm=TRUE) + d3
                                cnt <- cnt + cells
                        } else if (stat=='min') {
                                tmp <- .colMin(d, na.rm=na.rm)
                                st <- pmin(st, tmp, na.rm=na.rm)
                        } else if (stat=='max') {
                                tmp <- .colMax(d, na.rm=na.rm)
                                st <- pmax(st, tmp, na.rm=na.rm)

                        } else {
                                        # range
                                st <- apply(rbind(d, st), 2, fun, na.rm=na.rm)
                        }

                        pbStep(pb, i) 
                }


                if (stat == 'sd') {
                        meansq <- (st/cnt)^2
                        st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1)))
                        if (!asSample) {
                                st <- sqrt( st^2 * (cnt / (cnt-1)))
                        }
                } else if (stat == 'mean') {
                        st <- st / cnt
                } else if (stat == 'rms') {
                        if (asSample) {
                                st <- sqrt(sumsq/(cnt-1))
                        } else {
                                st <- sqrt(sumsq/cnt)
                        }
                } else if (stat == 'skew') {
                        if (asSample) {
                                stsd <- sqrt(sumsq/(cnt-1))^3
                        } else {
                                stsd <- sqrt(sumsq/cnt)^3
                        }
                        st <- d3 / (cnt*stsd)
                } else if (stat %in% c('min', 'max')) {
                        names(st) <- names(x)
                }

                pbClose(pb)
                return(st)
        }
)
setMethod('cellStats', signature(x='RasterLayer'),
        function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) {

                stopifnot(hasValues(x))
                stat <- .csTextFun(stat)

                if (! inMemory(x) ) {
                        if (canProcessInMemory(x)) {
                                x <- readAll(x)
                        }
                }
                if (inMemory(x) ) {
                        x <- getValues(x)
                        if (class(stat) == 'character') {
                                if (stat == mean ) {
                                        return( mean(x, na.rm=na.rm) )
                                } else if (stat == sum ) {
                                        return( sum(x, na.rm=na.rm) )
                                } else if (stat == 'countNA') { 
                                        return( sum(is.na(x)) )
                                } else if (stat == range ) {
                                        return( range(x, na.rm=na.rm) )
                                } else if (stat == min ) {
                                        return( min(x, na.rm=na.rm) )
                                } else if (stat == max ) {
                                        return( max(x, na.rm=na.rm) )
                                } else if (stat == sd ) {
                                        st <- sd(x, na.rm=na.rm)
                                        if (! asSample) {
                                                if (na.rm) {
                                                        n <- length(na.omit(x))
                                                } else {
                                                        n <- length(x)
                                                }
                                                st <- sqrt(st^2 * (n/(n-1)))
                                        } 
                                        return(st)
                                } else if (stat == 'rms') { 
                                        if (na.rm) {
                                                n <- sum(! is.na(x))
                                        } else {
                                                n <- length(x)
                                        }
                                        if (asSample) {
                                                n <- n-1
                                        }
                                        # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n))
                                        return(  sqrt( sum(x^2)/n ) )


                                } else if (stat == skew ) {
                                        if (na.rm) {
                                                x <- na.omit(x)
                                        }
                                        if (asSample) {
                                                sdx <- sd(x)
                                        } else {
                                                sdx <- sqrt(sum((x-mean(x))^2)/(length(x)))
                                        }
                                        return( sum( (x - mean(x))^3 ) / (length(x) * sdx^3) )
                                }
                        } else {
                                return( stat(x, na.rm=na.rm) )
                        }
                }


                if (class(stat) != 'character') {
                        stop('cannot use this function for large files')
                }

                st <- NULL
                counts <- FALSE
                if (stat == 'sum') {
                        fun <- sum
                        st <- 0 
                } else if (stat == 'min') {
                        fun <- min
                } else if (stat == 'max') {
                        fun <- max
                } else if (stat == 'range') {
                        fun <- range
                } else if (stat == 'countNA') {
                        st <- 0 
                        counts <- TRUE

                } else if (stat == 'skew') {
                        zmean <- cellStats(x, 'mean')
                        cnt <- 0
                        sumsq <- 0
                        d3 <- 0
                        counts <- TRUE

                } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') {
                        st <- 0 
                        sumsq <- 0
                        cnt <- 0
                        counts <- TRUE
                } else { 
                        stop(invalid 'stat'. Should be sum, min, max, sd, mean, or 'countNA') 
                }

                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='cellStats', ...)

                for (i in 1:tr$n) {
                        d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        if (counts) {
                                if (na.rm & stat != 'countNA') {
                                        nas <- sum(is.na(d) )
                                        if (nas == length(d)) { # only NAs 
                                                next 
                                        }
                                        cells <- length(d) - nas
                                } else {
                                        if (stat == 'countNA') {
                                                nas <- sum(is.na(d) )
                                        } else {
                                                cells <- length(d)
                                        }
                                }
                        }

                        if (stat=='mean') {
                                st <- sum(d, na.rm=na.rm) + st
                                cnt <- cnt + cells

                        } else if (stat=='sum') {
                                st <- sum(d, na.rm=na.rm) + st
                        } else if (stat == 'sd') {
                                st <- sum(d, na.rm=na.rm) + st
                                cnt <- cnt + cells
                                sumsq <- sum( d^2 , na.rm=na.rm) + sumsq
                        } else if (stat=='countNA') {
                                st <- st + nas

                        } else if (stat=='skew') {

                                d <- (d - zmean)
                                sumsq <- sum(d^2, na.rm=na.rm) + sumsq
                                d3 <- sum(d^3, na.rm=na.rm) + d3
                                cnt <- cnt + cells
                        } else if (stat=='rms') {
                                sumsq <- sum( d^2, na.rm=na.rm) + sumsq
                                cnt <- cnt + cells

                        } else {
                                st <- fun(d, st, na.rm=na.rm)
                        }

                        pbStep(pb, i) 
                }
                pbClose(pb)                     

                if (stat == 'sd') {
                        meansq <- (st/cnt)^2
                        st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1)))                  
                        if (!asSample) {
                                st <- sqrt( st^2 * (cnt / (cnt-1)))
                        }
                } else if (stat == 'mean') {
                        st <- st / cnt

                } else if (stat == 'rms') {
                        if (asSample) {
                                st <- sqrt(sumsq/(cnt-1))
                        } else {
                                st <- sqrt(sumsq/cnt)
                        }

                } else if (stat == 'skew') {
                        if (asSample) {
                                stsd <- sqrt(sumsq/(cnt-1))^3
                        } else {
                                stsd <- sqrt(sumsq/cnt)^3
                        }
                        st <- d3 / (cnt*stsd)
                }               
                return(st)
        }
)

41 cellValues.R

# Author: Robert J. Hijmans
# Date : November 2008
# Version 1.0
# Licence GPL v3

.cellValues <- function(x, cells, layer, nl, df=FALSE, factors=FALSE) { 

        if (inherits(x, 'RasterLayer')) {
                result <- .readCells(x, cells, 1)
                lyrs <- layer <- 1

        } else {

                nlyrs <- nlayers(x)
                if (missing(layer)) { layer <- 1 }
                layer <- min( max( round(layer), 1), nlyrs)
                if (missing(nl)) { nl <- nlyrs }
                nl <-  min( max( round(nl), 1), nlyrs-layer+1 )
                lyrs <- layer:(layer+nl-1)

                if (inherits(x, 'RasterStack')) {

                        result <- matrix(ncol=nl, nrow=length(cells))
                        colnames(result) <- names(x)[lyrs]
                        for (i in 1:length(lyrs)) {
                                result[,i] <- .readCells( x@layers[[lyrs[i]]], cells, 1)
                        }

                } else if (inherits(x, 'RasterBrick')) {

                        if (inMemory(x)) {
                                cells[cells < 1 | cells > ncell(x)] <- NA
                                if (length(na.omit(cells)) == 0) {
                                        return(cells)
                                }
                                result <- x@data@values[cells, lyrs, drop=FALSE] 

                        } else if (x@file@driver == 'netcdf') {
                                result <- .readBrickCellsNetCDF(x, cells, layer, nl) 

                        }  else {
                                result <- .readCells(x, cells, lyrs) 
                        }

                        if (is.null(dim(result))) { 
                                result <- matrix(result, ncol=length(lyrs))
                        }
                        colnames(result) <- names(x)[lyrs]
                }
        }
        if (df) {
                if (!is.matrix(result)) {
                        result <- matrix(result)
                        colnames(result) <- names(x)
                }
                result <- data.frame(ID=1:NROW(result), result)

                facts <- is.factor(x)[lyrs]
                if (any(facts) & factors) {
                        if (ncol(result) == 2) {
                                # possibly multiple columns added
                                result <- cbind(result[,1,drop=FALSE], factorValues(x, result[,2], layer))
                        } else {
                                # single columns only
                                i <- which(facts)
                                for (j in i) {
                                        result <- .insertColsInDF(result, factorValues(x, result[, j+1], j), j+1)
                                }
                        }
                }
        }
        result
}

42 clamp.R

# Author: Robert J. Hijmans
# Date : July 2013
# Version 1.0
# Licence GPL v3
if (!isGeneric(clamp)) {
        setGeneric(clamp, function(x, ...)
                standardGeneric(clamp))
}       
setMethod('clamp', signature(x='Raster'), 
function(x, lower=-Inf, upper=Inf, useValues=TRUE, filename='', ...) {
        if (!hasValues(x)) return(x)
        range <- as.numeric(c(lower[1], upper[1]))
        nl <- nlayers(x)
        if (nl > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)
        }
        useValues <- as.integer(useValues)
        if (canProcessInMemory(out)) {
                out <- setValues(out, .Call('clamp', values(x), range, useValues, NAOK=TRUE, PACKAGE='raster')) 
        } else {
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='clamp', ...)
                out <- writeStart(out, filename=filename, ...)

                for (i in 1:tr$n) {
                        vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                        vals <- .Call('clamp', vals, range, useValues, NAOK=TRUE, PACKAGE='raster')
                        if (nl > 1) {
                                vals <- matrix(vals, ncol=nl)
                        }
                        out <- writeValues(out, vals, tr$row[i])
                        pbStep(pb, i)
                }
                out <- writeStop(out)
                pbClose(pb)
        }
        return(out)
}
)

43 clearValues.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
.clearRaster <- function(object) {
        object@data@inmemory <- FALSE


#       object@data@indices = vector(mode='numeric')
        object@data@values <- vector()
        if ( !  fromDisk(object) ) {
                object@data@min <- Inf
                object@data@max <- -Inf 
                object@data@haveminmax <- FALSE
        }       
        return(object)
}
clearValues <- function(x) {
        if (class(x) == BasicRaster ) {
                return(x)
        } else if (inherits(x, RasterLayer )) {
                x <- .clearRaster(x)
        } else if (inherits(x, RasterStack) ) {
                for (i in seq(along=nlayers(x))) {
                        if (fromDisk(x@layers[[i]])) {
                                x@layers[[i]] <- .clearRaster(x@layers[[i]])
                        }
                }
        } else if (inherits(x, 'RasterBrick')) {
                x@data@values <- matrix(NA,0,0)
                x@data@inmemory <- FALSE

#               x@data@indices = c(0,0)
                if ( !  fromDisk(x) ) {
                        x@data@min <- rep(Inf, nlayers(x))
                        x@data@max <- rep(-Inf, nlayers(x))
                        x@data@haveminmax <- FALSE
                }
        } 
        return(x)
}
.clearFile <- function(x) {
        x@file@name <- ''
        x@data@fromdisk <- FALSE
        x@file@driver <- 
        return(x)
}

44 click.R

# Author: Robert J. Hijmans
# Date : January 2009 - December 2011
# Version 1.0
# Licence GPL v3
if (!isGeneric(click)) {
        setGeneric(click, function(x, ...)
                standardGeneric(click))
}       
.getClicks <- function(...) {
        res <- list()
        while(TRUE) {
                loc <- locator(1, ...)
                if (is.null(loc)) break
                res <- c(res, loc)
        }
        matrix(res, ncol=2, byrow=TRUE)
}
.getCellFromClick <- function(x, n, type, id, ...) {
        loc <- locator(n, type, ...)
        xyCoords <- cbind(x=loc$x, y=loc$y)
        if (id) {
                text(xyCoords, labels=1:n)
        }
        cells <- cellFromXY(x, xyCoords)
        cells <- unique(na.omit(cells))
        if (length(cells) == 0 ) { 
                stop('no valid cells selected') 
        }
        cells
}
setMethod('click', signature(x='missing'), 
        function(x, n=1, type=n, ...) {
                loc <- locator(n, type, ...)
                cbind(x=loc$x, y=loc$y)
        }
)

setMethod('click', signature(x='SpatialGrid'), 
        function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) {
                r <- raster(x)
                cells <- .getCellFromClick(r, n, type, id, ...)

                if (.hasSlot(x, 'data')) {
                        value <- x@data[cells, ,drop=FALSE]
                } else {
                        value <- NULL
                }
                if (cell) {
                        value <- data.frame(cells, value)
                }
                if (xy) { 
                        xyCoords <- xyFromCell(x, cells)
                        colnames(xyCoords) <- c('x', 'y')
                        value <- data.frame(xyCoords, value)
                } 
                value
        }
)
setMethod('click', signature(x='SpatialPixels'), 
        function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) {
                r <- raster(x)
                cells <- .getCellFromClick(r, n, type, id, ...)

                if (.hasSlot(x, 'data')) {
                        value <- x@data[cells, ,drop=FALSE]
                } else {
                        value <- NULL
                }
                if (cell) {
                        value <- data.frame(cells, value)
                }
                if (xy) { 
                        xyCoords <- xyFromCell(x, cells)
                        colnames(xyCoords) <- c('x', 'y')
                        value <- data.frame(xyCoords, value)
                } 
                value
        }
)
.oldclick <- function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type=n, ...) {

        cells <- .getCellFromClick(x, n, type, id, ...)
        value <- .cellValues(x, cells)

        if (is.null(dim(value))) { 
                value <- matrix(value)
                colnames(value) <- names(x)
        }
        if (cell) {
                value <- data.frame(cell=cells, value)
        }
        if (xy) { 
                xyCoords <- xyFromCell(x, cells)
                colnames(xyCoords) <- c('x', 'y')
                value <- data.frame(xyCoords, value)
        } 
        value
}
setMethod('click', signature(x='Raster'), 
        function(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type=n, show=TRUE, ...) {
        values <- NULL
        i <- 0
        n <- max(n, 1)
        while (i < n) {
                i <- i + 1
                loc <- locator(1, type, ...)
                xyCoords <- cbind(x=loc$x, y=loc$y)
                if (id) { 
                        text(xyCoords, labels=i) 
                }
                cells <- na.omit(cellFromXY(x, xyCoords))
                if (length(cells) == 0) break

                value <- extract(x, cells)
                if (cell) {
                        value <- data.frame(cell=cells, value)
                }
                if (xy) { 
                        xyCoords <- xyFromCell(x, cells)
                        colnames(xyCoords) <- c('x', 'y')
                        value <- data.frame(xyCoords, value)
                } 
                if (show) {
                        print(value)
                        flush.console()
                }
                if (is.null(dim(value))) { 
                        value <- matrix(value)
                        colnames(value) <- names(x)
                }
                values <- rbind(values, value)
        }
        if (show) {
                invisible(values)
        } else {
                values
        }
})

setMethod('click', signature(x='SpatialPolygons'),
        function(x, n=1, id=FALSE, xy=FALSE, type=n, ...) {
                loc <- locator(n, type, ...)
                xyCoords <- cbind(x=loc$x, y=loc$y)
                if (id) {
                        text(xyCoords, labels=1:n)
                }
                xyCoords <- SpatialPoints(xyCoords)
                xyCoords@proj4string <- x@proj4string
                i <- which(!is.na(over(x, xyCoords)))
                if (length(i) > 0) {
                        if (.hasSlot(x, 'data')) {
                                x <- x@data[i,]
                        } else {
                                x <- row.names(x)[i]
                        }
                } else {
                        x <- NULL
                }

                if (xy) {
                        x <- cbind(xyCoords, x)
                }
                return(x)
        }
)
setMethod('click', signature(x='SpatialLines'), 
        function(x, ...) {
                e <- as(drawExtent(), 'SpatialPolygons')
                e@proj4string <- x@proj4string
                i <- which(!is.na(over(x, e)))
                if (length(i) > 0) {
                        if (.hasSlot(x, 'data')) {
                                x <- x@data[i,]
                        } else {
                                x <- row.names(x)[i]
                        }
                } else {
                        x <- NULL
                }
                x
        }
)
setMethod('click', signature(x='SpatialPoints'), 
        function(x, ...) {
                e <- as(drawExtent(), 'SpatialPolygons')
                e@proj4string <- x@proj4string
                i <- which(!is.na(over(x, e)))
                if (length(i) > 0) {
                        if (.hasSlot(x, 'data')) {
                                x <- x@data[i,]
                        } else {
                                x <- row.names(x)[i]
                        }
                } else {
                        x <- NULL
                }
                x
        }
)

45 clump.R

# Authors: Robert J. Hijmans and Jacob van Etten, 
# Date : May 2010
# Version 1.0
# Licence GPL v3
# RH: updated for igraph (from igraph0)
# sept 23, 2012
if (!isGeneric(clump)) {
        setGeneric(clump, function(x, ...)
                standardGeneric(clump))
}       
.smallClump <- function(x, directions=8) {
        x1 <- raster(x)
        val <- which(getValues(x) != 0)
        if (length(val) == 0) { 
                return( setValues(x1, NA) )
        }
        adjv <- as.vector(t(adjacent(x1, val, directions=directions, target=val, pairs=TRUE)))
        # RH. To fix problem of missing single cells, perhaps more efficient than include=T in adjacent
        add <- val[! val %in% adjv]                
        adjv <- c(adjv, rep(add, each=2))  
        cl <- igraph::clusters(igraph::graph(adjv, directed=FALSE))$membership[val]
        cl <- as.numeric(as.factor(cl)) # RH force 1 to n
        x1[val] <- cl
        return(x1)
}
setMethod('clump', signature(x='RasterLayer'), 
function(x, filename='', directions=8, gaps=TRUE, ...) {
        if( !require(igraph)) {
                stop('you need to install the igraph package to be able to use this function')
        }
        if (! directions %in% c(4,8)) { stop('directions should be 4 or 8') }
        filename <- trim(filename)
        if (filename !=   & file.exists(filename)) {
                if (! .overwrite(...)) {
                        stop(file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it)
                }
        }
        datatype <- list(...)$datatype

        out <- raster(x)

        if (canProcessInMemory(out, 3)) {
                x <- .smallClump(x, directions)
                names(x) <- 'clumps'
                if (filename != '') {
                        if (is.null(datatype)) {
                                x <- writeRaster(x, filename, datatype='INT4S')
                        } else {
                                x <- writeRaster(x, filename, ...)
                        }
                }
                return(x)
        } 
        # else 
        names(out) <- 'clumps'
        out <- writeStart(out, filename=rasterTmpFile(), datatype='INT4S')
        tr <- blockSize(out, minrows=3)
        pb <- pbCreate(tr$n, label='clump', ...)

        ext <- c(xmin(out), xmax(out), ymax(out), NA)
        maxval <- 0

        rcl <- matrix(nrow=0, ncol=2)

        for (i in 1:tr$n) {

                ext[4] <- yFromRow(out, tr$row[i]) + 0.5 * yres(out)

                endrow <- tr$row[i] + tr$nrows[i] - 1 
                ext[3] <- yFromRow(out, endrow) - 1.5 * yres(out) # one additional row for overlap
                xc <- crop(x, extent(ext))

                xc <- .smallClump(xc, directions) + maxval
                if (i > 1) {
                        firstrow <- getValues(xc, 1)
                        rc <- na.omit(unique(cbind(lastrow, firstrow)))
                        rcl <- rbind(rcl, rc)
                }
                lastrow <- getValues(xc, nrow(xc))

                mv <- maxValue(xc)
                if (!is.na(mv)) {
                        maxval <- mv
                }
                out <- writeValues(out, getValues(xc, 1, tr$nrows[i]), tr$row[i])
                pbStep(pb)
        }
        out <- writeStop(out)
        pbClose(pb)


        if (nrow(rcl) > 0) {
                g <- igraph::graph.edgelist(rcl, directed=FALSE)
                clumps <- igraph::clusters(g)$membership
                rc <- cbind(V(g), clumps)
                i <- rc[,1] != rc[,2]
                rc <- rc[i, ,drop=FALSE]
                if (is.null(datatype)) {
                        out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, datatype='INT4S', ...)
                } else {
                        out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, ...)
                }
                return(out)

        } else if (!gaps) {
                un <- unique(out)
                un <- data.frame(cbind(un, clumps=1:length(un)))
                if (is.null(datatype)) {
                        return( subs(out, un, subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) )
                } else {
                        return( subs(out, un, subsWithNA=FALSE, filename=filename, ...) )
                }
        } else if (filename != '') {
                if (is.null(datatype)) {
                        return( writeRaster(out, filename=filename, datatype='INT4S', ...) )
                } else {
                        return( writeRaster(out, filename=filename, ...) )
                }

        } else {
                return(out)
        }
}
)

46 clusterR.R

# Author: Robert J. Hijmans
# Date :  November 2011
# Version 1.0
# Licence GPL v3
clusterR <- function(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) {
        if (is.null(cl)) {
                cl <- getCluster()
                on.exit( returnCluster() )
        }
        if (!is.null(export)) {
                snow::clusterExport(cl, export) 
        }

        nodes <- length(cl)

        out <- raster(x)
        m <- max(1, round(m))
        tr <- blockSize(x, minblocks=nodes*m )
        if (tr$n < nodes) {
                nodes <- tr$n
        }

        tr$row2 <- tr$row + tr$nrows - 1
        pb <- pbCreate(tr$n, label='clusterR', ...)

        if (!is.null(args)) {
                stopifnot(is.list(args))

                clusfun <- function(fun, i) {
                        r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                        r <- do.call(fun, c(r, args))
                        getValues(r)
                }

        } else {

                clusfun <- function(fun, i) {
                        r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                        r <- fun(r)
                        getValues(r)
                }
        }

        for (i in 1:nodes) {
                snow::sendCall(cl[[i]], clusfun, list(fun, i), tag=i)
        }

        if (canProcessInMemory(x)) {
                for (i in 1:tr$n) {
                        pbStep(pb, i)
                        d <- snow::recvOneData(cl)
                        if (! d$value$success ) { 
                                print(d$value$value)
                                stop('cluster error') 
                        }
                        if (i ==1) {
                                nl <- NCOL(d$value$value) 
                                if (nl > 1) {
                                        out <- brick(out, nl=nl)
                                }
                                res <- matrix(NA, nrow=ncell(out), ncol=nl)
                        } 

                        j <- d$value$tag
                        res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value
                        ni <- nodes + i
                        if (ni <= tr$n) {
                                snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni)
                        }
                }
                out <- setValues(out, res)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                }
                pbClose(pb)
                return(out)

        } else {

                for (i in 1:tr$n) {
                        pbStep(pb, i)

                        d <- snow::recvOneData(cl)
                        if (! d$value$success ) { stop('cluster error') }
                        if (i ==1) {
                                nl <- NCOL(d$value$value) 
                                if (nl > 1) {
                                        out <- brick(out, nl=nl)
                                }
                                out <- writeStart(out, filename=filename, ...)
                        } 

                        out <- writeValues(out, d$value$value, tr$row[d$value$tag])
                        ni <- nodes + i
                        if (ni <= tr$n) {
                                snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni)
                        }
                }
                out <- writeStop(out)
                pbClose(pb)
                return(out)
        }
}
.clusterR2 <- function(x, fun, args=NULL, filename='', cl=NULL, m=2, ...) {
        if (is.null(cl)) {
                cl <- getCluster()
                on.exit( returnCluster() )
        }
        nodes <- length(cl)

        out <- raster(x)
        m <- max(1, round(m))
        tr <- blockSize(x, minblocks=max(nodes+1, nodes*m))
        nodes <- min(nodes, tr$n-1)

        tr$row2 <- tr$row + tr$nrows - 1
        pb <- pbCreate(tr$n, label='clusterR', ...)
        canPiM <- canProcessInMemory(x)

        if (!is.null(args)) {
                stopifnot(is.list(args))

                if (canPiM) {
                        clusfun <- function(fun, i) {
                                r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                                r <- do.call(fun, c(r, args))
                                getValues(r)
                        }
                } else {
                        clusfun <- function(fun, i) {
                                r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                                r <- do.call(fun, c(r, args))
                                writeValues(out, getValues(r), tr$row[i])
                                return(i)
                        }
                }

        } else {

                if (canPiM) {
                        clusfun <- function(fun, i) {
                                r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                                r <- fun(r)
                                getValues(r)
                        }
                } else {
                        clusfun <- function(fun, i) {
                                r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out)))
                                r <- fun(r)
                                writeValues(out, getValues(r), tr$row[i])
                                return(i)
                        }
                }
        }


        if (canPiM) {
                for (i in 1:nodes) {
                        snow::sendCall(cl[[i]], clusfun, list(fun, i), tag=i)
                }

                for (i in 1:tr$n) {
                        pbStep(pb, i)
                        d <- snow::recvOneData(cl)
                        if (! d$value$success ) { stop('cluster error') }
                        if (i ==1) {
                                nl <- NCOL(d$value$value) 
                                if (nl > 1) {
                                        out <- brick(out, nl=nl)
                                }
                                res <- matrix(NA, nrow=ncell(out), ncol=nl)
                        } 

                        j <- d$value$tag
                        res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value
                        ni <- nodes + i
                        if (ni <= tr$n) {
                                snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni)
                        }
                }
                out <- setValues(out, res)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                }
                pbClose(pb)
                return(out)

        } else {

                r <- crop(x, extent(out, r1=tr$row[1], r2=tr$row2[1], c1=1, c2=ncol(out)))
                r <- fun(values(r))
                nl <- NCOL(r)
                if (nl > 1) {
                        out <- brick(out, nl=nl)
                }
                out <- writeStart(out, filename=filename, ...)
                out <- writeValues(out, r, 1)

                for (i in 1:nodes) {
                        snow::sendCall(cl[[i]], clusfun, list(fun, i+1), tag=i+1)
                }
                for (i in 2:tr$n) {
                        pbStep(pb, i)
                        d <- snow::recvOneData(cl)
                        if (! d$value$success ) { stop('cluster error') }

                        ni <- nodes + i
                        if (ni <= tr$n) {
                                snow::sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni)
                        }
                }

                out <- writeStop(out)
                pbClose(pb)
                return(out)
        }
}

47 coerce.R

# Author: Robert J. Hijmans
# Date : October 2008
# Version 0.9
# Licence GPL v3
# To sp pixel/grid objects      
setAs('Raster', 'GridTopology', 
        function(from) {
                rs <- res(from)
                orig <- bbox(from)[,1] + 0.5 * rs
                GridTopology(orig, rs, dim(from)[2:1] )
        }
)
setAs('GridTopology', 'RasterLayer',
        function(from) {
                raster(extent(from), nrows=from@cells.dim[2], ncols=from@cells.dim[1])
        }
)
setAs('Raster', 'SpatialPixels', 
        function(from) {
                if (rotated(from)) {
                        stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the rectify function')
                }       
                sp <- rasterToPoints(from, fun=NULL, spatial=FALSE)

                r <- raster(from)
                sp <- SpatialPoints(sp[,1:2], proj4string= projection(r, FALSE))
                grd <- as(r, 'GridTopology')
                SpatialPixels(points=sp, grid=grd)
        }
)
setAs('Raster', 'SpatialPixelsDataFrame', 
        function(from) { 
                if (rotated(from)) {
                        stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the rectify function')
                }       
                v <- rasterToPoints(from, fun=NULL, spatial=FALSE)
                r <- raster(from)
                sp <- SpatialPoints(v[,1:2], proj4string= projection(r, FALSE))
                grd <- as(r, 'GridTopology')

                if (ncol(v) > 2) {
                        v <- data.frame(v[, 3:ncol(v), drop = FALSE])
                        if (any(is.factor(from))) {
                                f <- levels(from)
                                for (i in 1:length(f)) {
                                        if (!is.null(f[[i]])) {
                                                v[,i] <- as.factor(f[[i]][v[,i]])
                                        }
                                }
                        }
                        SpatialPixelsDataFrame(points=sp, data=v, grid=grd)
                } else {
                        warning('object has no values, returning a SpatialPixels object')
                        SpatialPixels(points=sp, grid=grd)
                }
        }
)
setAs('Raster', 'SpatialGrid', 
        function(from) { 
                if (rotated(from)) {
                        stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the rectify function')
                }       
                r <- raster(from)
                crs <- projection(r, FALSE)
                grd <- as(r, 'GridTopology')
                SpatialGrid(grd, proj4string=crs)
        }
)
setAs('Raster', 'SpatialGridDataFrame', 
        function(from) { 
                if (rotated(from)) {
                        stop('\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the rectify function')
                }       
                r <- raster(from)
                crs <- projection(r, FALSE)
                grd <- as(r, 'GridTopology')
                if (hasValues(from)) {
                        sp <- SpatialGridDataFrame(grd, proj4string=crs, data=as.data.frame(from))
                } else { 
                        warning('object has no values, returning a SpatialGrid object')
                        sp  <- SpatialGrid(grd, proj4string=crs)
                }
                sp
        }
)
# To sp vector objects  
setAs('Raster', 'SpatialPolygons', 
        function(from){ 
                r <- rasterToPolygons(from[[1]])
                as(r, 'SpatialPolygons')
        }
)
setAs('Raster', 'SpatialPolygonsDataFrame', 
        function(from){ 
                return( rasterToPolygons(from) ) 
        } 
)
setAs('Raster', 'SpatialPoints', 
        function(from) { 
                SpatialPoints(rasterToPoints(from, spatial=FALSE)[,1:2], proj4string=projection(from, FALSE))
        }
)
setAs('Raster', 'SpatialPointsDataFrame', 
        function(from) { 
                rasterToPoints(from, spatial=TRUE)
        }
)
setAs('Extent', 'SpatialPolygons', 
        function(from){ 
                p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) )
                SpatialPolygons(list(Polygons(list(Polygon(p)), 1))) 
        }
)
setAs('Extent', 'SpatialPoints', 
        function(from){ 
                p <- cbind( x=c( from@xmin, from@xmin, from@xmax, from@xmax), y=c(from@ymin, from@ymax, from@ymin, from@ymax) )
                SpatialPoints(p)
        }
)
# to RasterLayer
setAs('SpatialGrid', 'RasterLayer', 
        function(from){ return(raster (from)) }
)
setAs('SpatialPixels', 'RasterLayer', 
        function(from){ return(raster (from)) }
)
setAs('SpatialGrid', 'BasicRaster', 
        function(from){ 
                to <- new('BasicRaster')
                to@extent <- extent(from)
                projection(to) <- from@proj4string
                dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1])    
                return(to)
        }
)
setAs('SpatialPixels', 'BasicRaster', 
        function(from){ 
                to <- new('BasicRaster')
                to@extent <- extent(from)
                projection(to) <- from@proj4string
                dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1])    
                return(to)
        }
)
# to RasterStack
setAs('SpatialGrid', 'RasterStack',
        function(from){ 
                stack(from)
        }
)
setAs('SpatialPixels', 'RasterStack', 
        function(from){
                stack(from)
        }
)
# to RasterBrick
setAs('SpatialGrid', 'RasterBrick',
        function(from){ 
                return(brick(from)) 
        }
)
setAs('SpatialPixels', 'RasterBrick', 
        function(from){ 
                return(brick(from)) 
        }
)
setAs('STFDF', 'RasterBrick', 
        function(from) {
                time <- from@time
                nc <- ncol(from@data)
                r <- raster(from@sp)
                b <- brick(r, nl=length(time) * nc)
                b <- setZ(b, rep(time, nc)) # rep changes some time formats
                names(b) <- paste(rep(colnames(from@data), each=length(time)), as.character(time), sep='')
                # need to improve this for character, factor variables
                m <- as.numeric(as.matrix(from@data))
                setValues(b, m)
        }
)
setAs('STSDF', 'RasterBrick', 
        function(from) {
                from <- as(from, 'STFDF')
                as(from, 'RasterBrick')
        }
)
# Between Raster objects
setAs('RasterStack', 'RasterLayer', 
        function(from){ return( raster(from)) }
)
setAs('RasterBrick', 'RasterLayer', 
        function(from){ return( raster(from)) }
)
setAs('RasterLayer', 'RasterStack', 
        function(from){ return( stack(from)) }
)
setAs('RasterLayer', 'RasterBrick', 
        function(from){ return( brick(from)) }
)
setAs('matrix', 'RasterLayer',
        function(from){ return(raster(from)) }
)
setAs('RasterLayer', 'matrix',
        function(from){ return( getValues(from, format='matrix')) }
)
setAs('RasterLayer', 'RasterLayerSparse', 
        function(from){ 
                x <- new('RasterLayerSparse', from)
                v <- na.omit(cbind(1:ncell(from), getValues(from)))
                setValues(x, v[,2], v[,1])
        }
)
setAs('RasterLayerSparse', 'RasterLayer', 
        function(from){
                raster(from)
        }
)
# image 
.rasterToImage <- function(r) {
   x <- xFromCol(r,1:ncol(r))
   y <- yFromRow(r, nrow(r):1)
   z <- t(as.matrix(r)[nrow(r):1,]) 
   list(x=x, y=y, z=z)
}

# spatstat
setAs('im', 'RasterLayer', 
        function(from) {
                r <- raster(nrows=from$dim[1], ncols=from$dim[2], xmn=from$xrange[1], xmx=from$xrange[2], ymn=from$yrange[1], ymx=from$yrange[2], crs='')
                r <- setValues(r, from$v)
                flip(r, direction='y')
        }
)
# adehabitat
setAs('asc', 'RasterLayer', 
        function(from) {
                d <- t(from[])
                d <- d[nrow(d):1, ]
                type <- attr(from, type) 
                if (type == 'factor') {
                        warning('factor type converted to numeric')
                }
                cz <- attr(from, cellsize)
                xmn <- attr(from, 'xll') - 0.5 * cz
                ymn <- attr(from, 'yll') - 0.5 * cz
                xmx <- xmn + ncol(d) * cz
                ymx <- ymn + nrow(d) * cz
                e <- extent(xmn, xmx, ymn, ymx)
                d <- raster(d)
                extent(d) = e
                return(d)
        }
)
setAs('RasterLayer', 'asc', 
        function(from) {
                asc <- getValues(from, format='matrix')
                asc <- asc[nrow(asc):1, ]
                attr(asc, cellsize) <- xres(from)
                attr(asc, xll) <- xmin(from) + 0.5 * xres(from)
                attr(asc, yll) <- ymin(from) + 0.5 * yres(from)
                attr(asc, type) <- 'numeric'
                class(asc) <- asc               
                return(asc)     
        }
)
setAs('kasc', 'RasterBrick', 
        function(from) {
                names <- colnames(from)
                cz <- attr(from, cellsize)
                ncol <- attr(from, 'ncol')
                nrow <- attr(from, 'nrow')
                xmn <- attr(from, 'xll') - 0.5 * cz
                ymn <- attr(from, 'yll') - 0.5 * cz
                xmx <- xmn + ncol * cz
                ymx <- ymn + nrow * cz
                e <- extent(xmn, xmx, ymn, ymx)
                b <- brick(e, nrow=nrow, ncol=ncol)
                m = matrix(NA, ncol=ncol(from), nrow=nrow(from))
                for (i in 1:ncol(m)) {
                        m[,i] <- as.numeric(from[,i])
                }       
                dim(m) <- dim(from)
                b <- setValues(b, m)
                names(b) <- names
                return(b)
        }
)
setAs('kasc', 'RasterStack', 
        function(from) {
                names <- colnames(from)
                cz <- attr(from, cellsize)
                ncol <- attr(from, 'ncol')
                nrow <- attr(from, 'nrow')
                xmn <- attr(from, 'xll') - 0.5 * cz
                ymn <- attr(from, 'yll') - 0.5 * cz
                xmx <- xmn + ncol * cz
                ymx <- ymn + nrow * cz
                e <- extent(xmn, xmx, ymn, ymx)
                r <- raster(e, nrow=nrow, ncol=ncol)
                r <- setValues(r, as.numeric(from[,1]))
                names(r) <- names[1]
                s <- stack(r)
                if (ncol(from) > 1) {
                        for (i in 2:ncol(from)) {
                                r <- setValues(r, as.numeric(from[,i]))
                                names(r) <- names[i]
                                s <- addLayer(s, r)
                        }       
                }
                return(s)
        }
)
# kernel density estimate (kde) from package ks
setAs('kde', 'RasterLayer', 
        function(from) {
                x <- t(from$estimate)
                x <- x[nrow(x):1,]
                raster(x, xmn=min(from$eval.points[[1]]), xmx=max(from$eval.points[[1]]), 
                                        ymn=min(from$eval.points[[2]]), ymx=max(from$eval.points[[2]]) ) 
        }
)
setAs('grf', 'RasterBrick', 
        function(from) {
                x <- from$data
                if (!is.matrix(x)) {
                        x <- matrix(x)
                }
                ncell <- nrow(x)
                nl <- ncol(x)
                nc <- nr <- as.integer(sqrt(ncell))
                dim(x) <- c(nr, nc, nl)

                x = aperm(x, perm=c(2,1,3))
                b <- brick(x)
                b <- flip(b, 'y')
                extent(b) <- extent(as.vector(apply(from$coords, 2, range)))
                b
        }
)
setAs('grf', 'RasterLayer', 
        function(from) {
                x <- from$data
                if (is.matrix(x)) {
                        x <- x[,1]
                }
                ncell <- length(x)
                nc <- nr <- as.integer(sqrt(ncell))
                dim(x) <- c(nr, nc)
                x <- t(x)[nrow(x):1,]
                r <- raster(x)
                extent(r) <- extent(as.vector(apply(from$coords, 2, range)))
                r
        }
)

48 commonDataType.R

# Author: Robert J. Hijmans
# Date : October 2011
# Version 1.0
# Licence GPL v3
.commonDataType <- function(dtype) {
        dtype <- as.vector(unlist(dtype))
        dtype <- unique(dtype)
        if (length(dtype)==1) {
                datatype <- dtype
        } else {
                dsize <- dataSize(dtype)
                dtype <- .shortDataType(dtype)
                if (any(dtype == 'FLT')) {
                        dsize <- max(dsize[dtype=='FLT'])
                        datatype <- paste('FLT', dsize, 'S', sep='')
                } else {
                        signed <- dataSigned(dtype)
                        dsize <- max(dsize)
                        if (all(signed)) {
                                datatype <- paste('INT', dsize, 'S', sep='')
                        } else if (all(!signed)) {
                                datatype <- paste('INT', dsize, 'U', sep='')
                        } else {
                                dsize <- ifelse(dsize == 1, 2, ifelse(dsize == 2, 4, 8))
                                datatype <- paste('INT', dsize, 'S', sep='')
                        }
                }
        }
        datatype
}

49 compareCRS.R

# author Robert Hijmans
# June 2010
# version 1.0
# license GPL3
.compareCRS <- function(...) {
        warning('use compareCRS, not .compareCRS')
        compareCRS(...)
}
compareCRS <- function(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) {

        x <- tolower(projection(x))
        y <- tolower(projection(y))

        step1 <- function(z) {
                z <- gsub(' ', '', z)
                if (!verbatim) {
                        z <- unlist( strsplit(z, '+', fixed=TRUE) )[-1]
                        z <- do.call(rbind, strsplit(z, '='))
                }
                z
        }

        if (verbatim) {
                if (!is.na(x) & !is.na(y)) {
                        return(x==y)
                } else {
                        if (is.na(x) & is.na(y)) {
                                return(TRUE) # ??
                        } else if (unknown) {
                                return(TRUE) 
                        } else {
                                return(FALSE)                   
                        }
                }
        }
        x <- step1(x)
        y <- step1(y)
        if (length(x) == 0 & length(y) == 0) {
                return(TRUE)
        } else if (length(x) == 0 | length(y) == 0) {
                if (unknown) {
                        return(TRUE)
                } else {
                        if (verbose) {
                                cat('Unknown CRS\n')
                        }
                        return(FALSE) 
                }
        }
        x <- x[x[,1] != 'towgs84', , drop=FALSE]
        x <- x[x[,1] != 'no_defs', , drop=FALSE]
        x <- x[which(x[,1] %in% y[,1]), ,drop=FALSE]
        y <- y[which(y[,1] %in% x[,1]), ,drop=FALSE]
        x <- x[order(x[,1]), ,drop=FALSE]
        y <- y[order(y[,1]), ,drop=FALSE]
        i <- x[,2] == y[,2]

        if (! all(i)) {
                if (verbose) {
                        i <- which(!i)
                        for (j in i) {
                                cat('+',x[j,1], ':  ', x[j,2],' != ', y[j,2], '\n', sep='') 
                        }
                }
                return(FALSE)
        }
        return(TRUE)
}

50 compare_Logical.R

# Authors: Robert J. Hijmans, r.hijmans@gmail.com 
# Date :  January 2009
# Version 0.9
# Licence GPL v3
.getAdjustedE <- function(r, tr, i, e) {
        startcell <- cellFromRowCol(r, tr$row[i] , 1)
        len <- cellFromRowCol(r, tr$row[i] + (tr$nrows[i]-1), ncol(r)) - startcell + 1
        n <- (startcell / length(e)) %% 1
        if (n > 0 ) {
                start <- round(n * length(e))
        } else {
                start <- 1
        }
        out <- c(e[start:length(e)], rep(e, floor(len/length(e))))
        out[1:len]
}
.asLogical <- function(x) {
        x[x!=0] <- 1
        return(x)
}
setMethod('==', signature(e1='BasicRaster', e2='BasicRaster'),
        function(e1,e2){
                cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) 
                return(cond)
        }
)       
setMethod('!=', signature(e1='BasicRaster', e2='BasicRaster'),
        function(e1,e2){
                cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) 
                return(!cond)
        }
)       
setMethod('!', signature(x='Raster'),
        function(x){
                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        return(setValues(r, ! getValues(x)))
                } else {
                        tr <- blockSize(r)
                        pb <- pbCreate(tr$n)                    
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- ! .asLogical(getValues(x, row=tr$row[i], nrows=tr$nrows[i]))
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)               
                }
        }
)       
setMethod(Compare, signature(e1='Raster', e2='logical'),
        function(e1,e2){
                nl <- nlayers(e1)
                if (nl > 1) {
                        r <- brick(e1, values=FALSE)
                } else {
                        r <- raster(e1)
                }

                if (length(e2) > 1 & nl > 1) {
                        if (length(e2) != nl) {
                                a <- rep(NA, nl)
                                a[] <- e2
                                e2 <- a
                        }
                        if (canProcessInMemory(r, 3)) {
                                dataType(r) <- 'LOG1S'
                                r <- setValues(r, values=t(callGeneric(t(getValues(e1)), e2 ) ) )
                        } else {
                                tr <- blockSize(r)
                                pb <- pbCreate(tr$n)
                                r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                                for (i in 1:tr$n) {
                                        v <- t(callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2))
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i) 
                                }
                                r <- writeStop(r)
                                pbClose(pb)
                        }

                } else {        

                        if (canProcessInMemory(r, 3)) {
                                dataType(r) <- 'LOG1S'
                                if (length(e2) > ncell(r)) {
                                        e2 <- e2[1:ncell(r)]
                                }
                                r <- setValues(r, values=callGeneric(getValues(e1), e2 ) )                      
                        } else {
                                tr <- blockSize(r)
                                pb <- pbCreate(tr$n)
                                r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                                if (length(e2) > 0) {
                                        for (i in 1:tr$n) {
                                                e <- .getAdjustedE(r, tr, i, e2)
                                                v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e)
                                                r <- writeValues(r, v, tr$row[i])
                                                pbStep(pb, i) 
                                        }
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2)
                                                r <- writeValues(r, v, tr$row[i])
                                                pbStep(pb, i)
                                        }
                                }
                                r <- writeStop(r)
                                pbClose(pb)
                        }
                }
                return(r)
        }
)
setMethod(Compare, signature(e1='logical', e2='Raster'),
        function(e1,e2){
                callGeneric(e2, e1)
        }
)
setMethod(Compare, signature(e1='Raster', e2='numeric'),
        function(e1, e2){
                nl <- nlayers(e1)
                if (nl > 1) {
                        r <- brick(e1, values=FALSE)
                } else {
                        r <- raster(e1)
                }

                if (length(e2) > 1 & nl > 1) {
                        if (length(e2) != nl) {
                                a <- rep(NA, nl)
                                a[] <- e2
                                e2 <- a
                        }
                        if (canProcessInMemory(r, 3)) {
                                dataType(r) <- 'LOG1S'
                                r <- setValues(r, values=t(callGeneric(t(getValues(e1)), e2 ) ) )
                        } else {
                                tr <- blockSize(r)
                                pb <- pbCreate(tr$n)
                                r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                                for (i in 1:tr$n) {
                                        v <- t(callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2))
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i) 
                                }
                                r <- writeStop(r)
                                pbClose(pb)
                        }

                } else {        

                        if (canProcessInMemory(r, 3)) {
                                dataType(r) <- 'LOG1S'
                                if (length(e2) > ncell(r)) {
                                        e2 <- e2[1:ncell(r)]
                                }
                                r <- setValues(r, values=callGeneric(getValues(e1), e2))
                        } else {
                                tr <- blockSize(r)
                                pb <- pbCreate(tr$n)
                                r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )

                                if (length(e2) > 0) {
                                        for (i in 1:tr$n) {
                                                e <- .getAdjustedE(r, tr, i, e2)
                                                v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e)
                                                r <- writeValues(r, v, tr$row[i])
                                                pbStep(pb, i) 
                                        }
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2)
                                                r <- writeValues(r, v, tr$row[i])
                                                pbStep(pb, i)
                                        }
                                }

                                r <- writeStop(r)
                                pbClose(pb)
                        }
                }
                return(r)

        }
)       
setMethod(Compare, signature(e1='numeric', e2='Raster'),
        function(e1,e2){
                callGeneric(e2, e1)
        }
)       
setMethod(Compare, signature(e1='Raster', e2='Raster'),
    function(e1, e2){ 

                if (nlayers(e1) > 1) {
                        if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) {
                                stop('number of layers of objects do not match')
                        }
                        r <- brick(e1, values=FALSE)
                } else if (nlayers(e2) > 1) {
                        r <- brick(e2, values=FALSE)
                } else {
                        r <- raster(e1)
                }

                cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) 
                if (!cond) {
                        stop(Cannot compare Rasters that have different BasicRaster attributes. See compare())
                }       

                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        r <- setValues(r, callGeneric(getValues(e1), getValues(e2)))
                } else {
                        tr <- blockSize(r)
                        pb <- pbCreate(tr$n)
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                }       
                return(r)
        }
)
setMethod(Logic, signature(e1='Raster', e2='Raster'),
    function(e1, e2){ 

                if (nlayers(e1) > 1) {
                        r <- brick(e1, values=FALSE)
                        if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) {
                                stop('number of layers of objects do not match')
                        }
                } else if (nlayers(e2) > 1) {
                        r <- brick(e2, values=FALSE)
                } else {
                        r <- raster(e1)
                }

                cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) 
                if (!cond) {
                        stop(Cannot compare Rasters that have different BasicRaster attributes. See compare())
                }       

                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        r <- setValues(r, callGeneric(.asLogical(getValues(e1)), .asLogical(getValues(e2))))
                } else {
                        tr <- blockSize(r)
                        pb <- pbCreate(tr$n)
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- callGeneric(.asLogical(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), .asLogical(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])))
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                }       
                return(r)
        }
)
setMethod(Compare, signature(e1='Extent', e2='Extent'),
        function(e1,e2){
                a <- callGeneric(e2@xmin, e1@xmin)
                b <- callGeneric(e1@xmax, e2@xmax)
                c <- callGeneric(e2@ymin, e1@ymin)
                d <- callGeneric(e1@ymax, e2@ymax)
                a & b & c & d
        }
)

51 compare.R

# Author: Robert J. Hijmans
# Date : October 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(all.equal)) {
        setGeneric(all.equal, function(target, current, ...)
                standardGeneric(all.equal))
}       
setMethod(all.equal, c(Raster, Raster),
        function(target, current, values=TRUE, stopiffalse=FALSE, showwarning=TRUE, ...) { 
                compareRaster(target, current, ..., values=values, stopiffalse=stopiffalse, showwarning=showwarning)
        }
)
compareRaster <- function(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) {
        if (missing(tolerance)) {
                tol <- .tolerance()
        } else {
                tol <- tolerance
        }

        result <- TRUE
        objects <- c(x, list(...))
        if (!isTRUE(length(objects) > 1)) {
                warning('There should be at least 2 Raster* objects to compare')
                return(result)
        }       
        minres <- min(res(objects[[1]]))
        proj1 <- projection(objects[[1]])
        ext1 <- extent(objects[[1]])
        ncol1 <- ncol(objects[[1]])
        nrow1 <- nrow(objects[[1]])
        res1 <- res(objects[[1]])
        origin1 <- abs(origin(objects[[1]]))
        rot1 <- rotated(objects[[1]])   

        for (i in 2:length(objects)) { 
                if (extent) {
                        if (!(isTRUE(all.equal(ext1, extent(objects[[i]]), tolerance=tol, scale=minres )))) {
                                result <- FALSE
                                if (stopiffalse) { stop('different extent') }
                                if (showwarning) { warning('different extent') }
                        }       
                }       
                if (rowcol) {
                        if ( !(identical(ncol1, ncol(objects[[i]]))) ) {
                                result <- FALSE
                                if (stopiffalse) { stop('different number or columns') } 
                                if (showwarning) { warning('different number or columns') } 
                        }       
                        if ( !(identical(nrow1, nrow(objects[[i]]))) ) {
                                result <- FALSE
                                if (stopiffalse) { stop('different number or rows') }
                                if (showwarning) { warning('different number or rows') }
                        }
                }
                if (crs) {
                        thisproj <- projection(objects[[i]])
                        if (is.na(proj1)) {
                                proj1 <- thisproj
                        } else {
                                crs <- try (compareCRS(proj1, thisproj, unknown=TRUE), silent=TRUE)
                                if (class(crs) == 'try-error') {
                                        if (stopiffalse) { stop('invalid CRS') }
                                        if (showwarning) { warning('invalid CRS') }
                                } else if (!crs) {
                                        result <- FALSE
                                        if (stopiffalse) { stop('different CRS') }
                                        if (showwarning) { warning('different CRS') }
                                }
                        }
                }

# Can also check res through extent & rowcol
                if (res) {
                        if (!(isTRUE(all.equal(res1, res(objects[[i]]), tolerance=tol, scale=minres)))) {
                                result <- FALSE
                                if (stopiffalse)  { stop('different resolution') }
                                if (showwarning) { warning('different resolution') }
                        }       
                }
# Can also check orig through extent & rowcol, but orig is useful for e.g. Merge(raster, raster)
                if (orig) {
                        dif <- origin1 - abs(origin(objects[[i]]))
                        if (!(isTRUE(all.equal(dif, c(0,0), tolerance=tol, scale=minres)))) {
                                result <- FALSE
                                if (stopiffalse) { stop('different origin') }
                                if (showwarning) { warning('different origin') }
                        }
                }

                if (rotation) {
                        rot2 <- rotated(objects[[i]])
                        if (rot1 | rot2) {
                                if (rot1 != rot2) {
                                        if (stopiffalse) { stop('not all objects are rotated') }
                                        if (showwarning) { warning('not all objects are rotated') }
                                        result <- FALSE
                                } else {
                                        test <- all(objects[[i]]@rotation@geotrans == objects[[1]]@rotation@geotrans)
                                        if (! test) {
                                                if (stopiffalse) { stop('rotations are different') }
                                                if (showwarning) { warning('rotations are different') }
                                                result <- FALSE
                                        }
                                }
                        }
                }

                if (values) {
                        hv1 <- hasValues(objects[[1]])
                        hvi <- hasValues(objects[[i]])
                        if (hv1 != hvi) {
                                if (stopiffalse) { stop('not all objects have values') }
                                if (showwarning) { warning('not all objects have values') }
                                result <- FALSE
                        } else if (hv1 & hvi) { 
                                if (canProcessInMemory(objects[[1]])) {
                                        test <- isTRUE(all.equal(getValues(objects[[1]]), getValues(objects[[i]])))
                                        if (! test) {
                                                if (stopiffalse) { stop('not all objects have the same values') }
                                                if (showwarning) { warning('not all objects have the same values') }
                                                result <- FALSE
                                        }       
                                } else {
                                        tr <- blockSize(objects[[1]])
                                        for (j in 1:tr$n) {
                                                v1 <- getValues(objects[[1]], tr$row[j], tr$nrows[j])
                                                v2 <- getValues(objects[[i]], tr$row[j], tr$nrows[j])
                                                if (!isTRUE(all.equal(v1, v2))) {
                                                        if (stopiffalse) { stop('not all objects have the same values') }
                                                        if (showwarning) { warning('not all objects have the same values') }
                                                        result <- FALSE
                                                        break
                                                }
                                        }
                                }
                        }
                }
        }
        return(result)
}

52 connection.R

# Author: Robert J. Hijmans
# Date : June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(readStart)) {
        setGeneric(readStart, function(x, ...)
                standardGeneric(readStart))
}       
setMethod('readStart', signature(x='Raster'), 
        function(x, ...) {
                if ( fromDisk(x) ) {
                        return (.openConnection(x, ...))
                } else {
                        return(x)
                }
        }
)
setMethod('readStart', signature(x='RasterStack'), 
        function(x, ..., maxopen=100) {
                fd <- sapply(x@layers, fromDisk)
                ld <- sum(fd)
                if (isTRUE( ld > 0 & ld <= maxopen)) {
                        d <- which(fd)
                        for (i in d) {
                                x@layers[[i]] <- readStart(x@layers[[i]], con.check=103, ...)
                        }
                }
                x
        }
)
.openConnection <- function(x, silent=TRUE, con.check=Inf, ...) {
        fn <- trim(x@file@name)
        driver <- .driver(x)
        if (driver == gdal) {
                attr(x@file, con) <- rgdal::GDAL.open(fn, silent=silent)
                x@file@open <- TRUE
        } else  if (.isNativeDriver(driver))  {
                # R has a max of 128 connections
                if (length(getAllConnections()) < con.check) {
                        fn <- .setFileExtensionValues(fn, driver)
                        attr(x@file, con) <- file(fn, rb)
                        x@file@open <- TRUE
                }
        } else if (driver == 'netcdf') {
                if (isTRUE(getOption('rasterNCDF4'))) {
                        attr(x@file, 'con') <- ncdf4::nc_open(x@file@name)
                } else {
                        attr(x@file, 'con') <- ncdf::open.ncdf(x@file@name)
                }
                x@file@open <- TRUE
#       } else if (driver == 'ascii') { # cannot be opened
        }       
        x
}
if (!isGeneric(readStop)) {
        setGeneric(readStop, function(x, ...)
                standardGeneric(readStop))
}       
setMethod('readStop', signature(x='Raster'), 
        function(x, ...) {
                if ( fromDisk(x) ) {
                        return (.closeConnection(x))
                } else {
                        return(x)
                }
        }
)
setMethod('readStop', signature(x='RasterStack'), 
        function(x, ...) {
                d <- which(sapply(x@layers, fromDisk))
                if (length(d) > 0) {
                        for (i in d) {
                                x@layers[[i]] <- readStop(x@layers[[i]], ...)
                        }
                }
                x
        }
)
.closeConnection <- function(x) {
        driver <- .driver(x)
        if (driver == gdal) {
                try( rgdal::closeDataset(x@file@con), silent = TRUE )
        } else if (.isNativeDriver(driver))  {
                try( close(x@file@con), silent = TRUE )
        } else if (driver == 'netcdf') {
                if (isTRUE(getOption('rasterNCDF4'))) {
                        ncdf4::nc_close(x@file@con)
                } else {
                        ncdf::close.ncdf(x@file@con)
                }       
        } else if (driver == 'ascii') { }

        x@file@open <- FALSE
        attr(x@file, 'con') <- NULL
        x
#       attr(x@file, con <- )
}

53 contour.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  April 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(contour)) {
        setGeneric(contour, function(x,...)
                standardGeneric(contour))
}       
setMethod(contour, signature(x='RasterLayer'), 
        function(x, maxpixels=100000, ...)  {
                x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE)
                contour(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...)
        }
)
rasterToContour <- function(x, maxpixels=100000, ...) {
        x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE)
        cL <- contourLines(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...)

# The below was taken from ContourLines2SLDF(maptools), by Roger Bivand & Edzer Pebesma 
        .contourLines2LineList <- function(cL) {
                n <- length(cL)
                res <- vector(mode=list, length=n)
                for (i in 1:n) {
                        crds <- cbind(cL[[i]][[2]], cL[[i]][[3]])
                        res[[i]] <- Line(coords=crds)
                }
                res
        }

    if (length(cL) < 1) stop(no contour lines)
    cLstack <- tapply(1:length(cL), sapply(cL, function(x) x[[1]]), function(x) x, simplify = FALSE)
    df <- data.frame(level = names(cLstack))
    m <- length(cLstack)
    res <- vector(mode = list, length = m)
    IDs <- paste(C, 1:m, sep = _)
    row.names(df) <- IDs
    for (i in 1:m) {
        res[[i]] <- Lines(.contourLines2LineList(cL[cLstack[[i]]]), ID = IDs[i])
    }
    SL <- SpatialLines(res, proj4string = projection(x, asText=FALSE))
    SpatialLinesDataFrame(SL, data = df)

}
filledContour <- function(x, y=1, maxpixels=100000, ...) {
        if (nlayers(x) > 1) {   
                y <- min(max(1, y), nlayers(x))
                x <- raster(x, y) 
        }
        x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE)
        X <- xFromCol(x, 1:ncol(x))
        Y <- yFromRow(x, nrow(x):1)
        Z <- t( matrix( getValues(x), ncol=x@ncols, byrow=TRUE)[nrow(x):1,] )
        filled.contour(x=X,y=Y,z=Z,...)
}

54 corLocal.R

# Author: Robert J. Hijmans
# Date : February 2014
# Version 1.0
# Licence GPL v3
if ( !isGeneric(corLocal) ) {
        setGeneric(corLocal, function(x, y, ...)
                standardGeneric(corLocal))
}
setMethod('corLocal', signature(x='RasterLayer', y='RasterLayer'), 
        function(x, y, ngb=5, method = c(pearson, kendall, spearman), test=FALSE, filename='', ...) {

                compareRaster(x,y)
                if (test) {
                        out <- brick(x, values=FALSE, nl=2)
                        names(out) <- c(method[1], 'p-value')
                } else {
                        out <- raster(x)
                        names(out) <- c(method[1])              
                }

                if (canProcessInMemory(x, n=2*ngb)) {
                        vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb)
                        vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb)
                        if (test)  {
                                v <- matrix(NA, ncol=2, nrow=ncell(x))
                                for (i in 1:ncell(x)) {
                                        z <- na.omit(cbind(vx[i,], vy[i,]))     
                                        if (nrow(z) > 2) {
                                                a <- cor.test(z[,1], z[,2], method=method)
                                                v[i, ] <- c(a$estimate, a$p.value)
                                        }
                                }
                        } else {
                                v <- rep(NA, nrow=ncell(x))
                                for (i in 1:ncell(x)) {
                                        z <- na.omit(cbind(vx[i,], vy[i,]))     
                                        if (nrow(z) > 2) {
                                                v[i] <- cor(z[,1], z[,2], method=method)
                                        }
                                }
                        }
                        out <- setValues(out, v)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='corLocal', ...)
                        out <- writeStart(out, filename=filename, ...)
                        if (test) {
                                for (i in 1:tr$n) {
                                        vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb)
                                        vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb)
                                        v <- matrix(NA, ncol=2, nrow=nrow(vx))
                                        for (j in 1:nrow(vx)) {
                                                z <- na.omit(cbind(vx[j,], vy[j,]))     
                                                if (nrow(z) > 2) {
                                                        a <- cor.test(z[,1], z[,2], method=method)
                                                        v[j, ] <- c(a$estimate, a$p.value)
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb)
                                        vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb)
                                        v <- rep(NA, nrow(vx))
                                        for (j in 1:length(v)) {
                                                z <- na.omit(cbind(vx[j,], vy[j,]))     
                                                if (nrow(z) > 2) {
                                                        v[j] <- cor(z[,1], z[,2], method=method)
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                }
                        }
                        return(writeStop(out))
                }
        }
)
setMethod('corLocal', signature(x='RasterStackBrick', y='RasterStackBrick'), 
        function(x, y, method = c(pearson, kendall, spearman), test=FALSE, filename='', ...) {

                compareRaster(x,y)
                nl1 <- nlayers(x)
                nl2 <- nlayers(y)
                if (nl1 != nl2) {
                        stop('nlayers does not match')
                }
                if (nl1 < 3) {
                        stop('number of layers should be > 2')
                }


                if (test) {
                        out <- brick(x, values=FALSE, nl=2)
                        names(out) <- c(method[1], 'p-value')
                } else {
                        out <- raster(x)
                        names(out) <- c(method[1])              
                }

                if (canProcessInMemory(x)) {
                        vx <- getValues(x)
                        vy <- getValues(y)
                        if (test)  {
                                v <- matrix(NA, ncol=2, nrow=ncell(x))
                                for (i in 1:ncell(x)) {
                                        z <- na.omit(cbind(vx[i,], vy[i,]))     
                                        if (nrow(z) > 2) {
                                                a <- cor.test(z[,1], z[,2], method=method)
                                                v[i, ] <- c(a$estimate, a$p.value)
                                        }
                                }
                        } else {
                                v <- rep(NA, nrow=ncell(x))
                                for (i in 1:ncell(x)) {
                                        z <- na.omit(cbind(vx[i,], vy[i,]))     
                                        if (nrow(z) > 2) {
                                                v[i] <- cor(z[,1], z[,2], method=method)
                                        }
                                }
                        }
                        out <- setValues(out, v)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='corLocal', ...)
                        out <- writeStart(out, filename=filename, ...)
                        if (test) {
                                for (i in 1:tr$n) {
                                        vx <- getValues(x, tr$row[i], tr$nrows[i])
                                        vy <- getValues(y, tr$row[i], tr$nrows[i])
                                        v <- matrix(NA, ncol=2, nrow=nrow(vx))
                                        for (j in 1:nrow(vx)) {
                                                z <- na.omit(cbind(vx[j,], vy[j,]))     
                                                if (nrow(z) > 2) {
                                                        a <- cor.test(z[,1], z[,2], method=method)
                                                        v[j, ] <- c(a$estimate, a$p.value)
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        vx <- getValues(x, tr$row[i], tr$nrows[i])
                                        vy <- getValues(y, tr$row[i], tr$nrows[i])
                                        v <- rep(NA, nrow(vx))
                                        for (j in 1:length(v)) {
                                                z <- na.omit(cbind(vx[j,], vy[j,]))     
                                                if (nrow(z) > 2) {
                                                        v[j] <- cor(z[,1], z[,2], method=method)
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                }
                        }
                        return(writeStop(out))
                }
        }
)

55 cor.R

.cor <- function(x, n=Inf, ...) {

                nl <- nlayers(x)
                if (nl < 2) return(1)

                if (n < ncell(x)) {
                        x <- sampleRegular(x, size=n, asRaster=TRUE)
                }

                if (canProcessInMemory(x, nlayers(x)*4)) {
                        s <- na.omit(getValues(x))
                        s <- cor(s)
                } else {
                        msk <- sum(x, na.rm=FALSE)
                        x <- mask(x, msk)
                        mx <- cellStats(x, mean)
                        sx <- cellStats(x, sd)
                        nc <- ncell(x)
                        s <- matrix(NA, nrow=n, ncol=n)
                        for (i in 1:(nl-1)) {
                                for (j in (i+1):nl) {
                                        s[j,i] <- s[i,j] <- cellStats(((x[[i]] - mx[i]) * (x[[j]] - mx[j])) / (sx[i] * sx[j]), sum)/ (nc-1)
                                }
                        }
                        diag(s) <- 1                    
                }
                if (nrow(s) == 2) {
                        s[2,1]
                } else {
                        colnames(s) <- rownames(s) <- names(x)
                        s               
                }
}

56 coverBrick.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(cover)) {
        setGeneric(cover, function(x, y, ...)
                standardGeneric(cover))
}       
setMethod('cover', signature(x='RasterStackBrick', y='Raster'), 
        function(x, y, ..., filename=''){ 
        rasters <- .makeRasterList(x, y, ..., unstack=FALSE)
        nl <- sapply(rasters, nlayers)
        un <- unique(nl)
        if (length(un) > 3) {
                stop('number of layers does not match')
        } else if (length(un) == 2 & min(un) != 1) {
                stop('number of layers does not match')
        } else if (nl[1] != max(un)) {
                stop('number of layers of the first object must be the highest') 
        }

        outRaster <- brick(x, values=FALSE)

        filename <- trim(filename)
        dots <- list(...)
        if (is.null(dots$format))  { 
                format <- .filetype(format=format, filename=filename)
        } else { 
                format <- dots$format 
        }
        if (is.null(dots$overwrite)) { 
                overwrite <- .overwrite()       
        } else {
                overwrite <- dots$overwrite
        }
        if (is.null(dots$progress)) { 
                progress <- .progress() 
        } else {
                progress <- dots$progress
        }
        if (is.null(dots$datatype)) { 
                datatype <- unique(dataType(x))
                if (length(datatype) > 1) {
                        datatype <- .commonDataType(datatype)
                }
        } else {
                datatype <- dots$datatype
        }       

        if ( canProcessInMemory(x, sum(nl)+nl[1])) {
                v <- getValues( rasters[[1]] )
                v2 <- v
                for (j in 2:length(rasters)) {
                        v2[] <- getValues( rasters[[j]] )
                        v[is.na(v)] <- v2[is.na(v)]
                }       
                outRaster <- setValues(outRaster, v)
                if (filename != '') {
                        outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress )
                }

        } else {

                if (filename == '') { filename <- rasterTmpFile() }
                outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite)

                tr <- blockSize(outRaster, sum(nl))
                pb <- pbCreate(tr$n, label='cover', progress=progress)
                for (i in 1:tr$n) {
                        v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] )
                        v2 <- v
                        for (j in 2:length(rasters)) {
                                v2[] <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i])
                                v[is.na(v)] <- v2[is.na(v)]
                        }       
                        outRaster <- writeValues(outRaster, v, tr$row[i])
                        pbStep(pb, i) 
                }
                pbClose(pb)
                outRaster <- writeStop(outRaster)
        }
        return(outRaster)
}
)

57 coverPolygons.R

# Author: Robert J. Hijmans
# Date : December 2011
# Version 1.0
# Licence GPL v3
if (!isGeneric(cover)) {
        setGeneric(cover, function(x, y, ...)
                standardGeneric(cover))
}       
setMethod('cover', signature(x='SpatialPolygons', y='SpatialPolygons'), 
        function(x, y, ..., identity=FALSE){ 

        stopifnot(require(rgeos))

        yy <- list(y, ...)
        i <- which(sapply(yy, function(x) inherits(x, 'SpatialPolygons')))
        if (length(i)==0) {
                stop('additional arguments should be of class SpatialPolygons')
        } else if (length(i) < length(yy)) {
                warning('additional arguments that are not of class SpatialPolygons are ignored')
                yy <- yy[i]
        } 
        if (identity) {
                return(.coverIdentity(x, yy))
        }

        haswarned <- FALSE
        for (y in yy) {
                if (! identical(proj4string(x), proj4string(y)) ) {
                        if (!haswarned) {
                                warning('non identical CRS')
                                haswarned <- TRUE
                        }
                        y@proj4string <- x@proj4string
                }       
                subs <- rgeos::gIntersects(x, y, byid=TRUE)
                if (!any(subs)) {
                        next
                } else {
                        int <- crop(y, x)
                        x <- erase(x, int)
                        x <- bind(x, int)
                }
        }
        x
} 
)
.coverIdentity <- function(x, yy) {
        haswarned <- FALSE
        for (y in yy) {
                if (! identical(proj4string(x), proj4string(y)) ) {
                        if (!haswarned) {
                                warning('non identical CRS')
                                haswarned <- TRUE
                        }
                        y@proj4string <- x@proj4string
                }       

                i <- rgeos::gIntersects(x, y)
                if (!i) {
                        next
                }

                x <- spChFIDs(x, as.character(1:length(x)))
                y <- spChFIDs(y, as.character(1:length(y)))
                if (.hasSlot(x, 'data')) {
                        xnames <- colnames(x@data)
                } else {
                        xnames <-NULL
                }
                if (.hasSlot(y, 'data')) {
                        ynames <- colnames(y@data)
                } else {
                        ynames <-NULL
                }
                if (is.null(xnames) & !is.null(ynames)) {
                        dat <- y@data[NULL, ,drop=FALSE]
                        dat[1:length(x), ] <- NA
                        x <- SpatialPolygonsDataFrame(x, dat)
                        xnames <- ynames
                }

                yinx <- which(ynames %in% xnames)
                doAtt <- TRUE
                if (length(yinx) == 0) {
                        doAtt <- FALSE
                }

                subs <- rgeos::gIntersects(x, y, byid=TRUE)
                subsx <- apply(subs, 2, any)
                subsy <- apply(subs, 1, any)

                int  <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_not_poly=TRUE)
                #if (inherits(int, SpatialCollections)) {
                #       if (is.null(int@polyobj)) { # ??
                #               warning('polygons do not intersect')
                #               next
                #       }
                #       int <- int@polyobj
                #}
                if (!inherits(int, 'SpatialPolygons')) {
                        warning('polygons do not intersect')
                        next
                }
                if (doAtt) {
                        ids <- do.call(rbind, strsplit(row.names(int), ' '))
                        idsy <- match(ids[,2], rownames(y@data))
                        rows <- 1:length(idsy)

                        dat <- x@data[NULL, ,drop=FALSE]
                        dat[rows, yinx] <- y@data[idsy, yinx]
                        int <- SpatialPolygonsDataFrame(int, dat, match.ID=FALSE)
                }
                x <- erase(x, int)
                if (is.null(x)) {
                        x <- int
                } else {
                        x <- bind(x, int)
                }
        }
        x
}

58 cover.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(cover)) {
        setGeneric(cover, function(x, y, ...)
                standardGeneric(cover))
}       
setMethod('cover', signature(x='RasterLayer', y='RasterLayer'), 
        function(x, y, ..., filename=''){ 

        rasters <- .makeRasterList(x, y, ...)
        nl <- sapply(rasters, nlayers)
        if (max(nl) > 1) {
                stop(Only single layer (RasterLayer) objects can be used if 'x' and 'y' have a single layer)
        } 

        outRaster <- raster(x)
        compareRaster(c(outRaster, rasters))

        filename <- trim(filename)
        dots <- list(...)
        if (is.null(dots$format))  { 
                format <- .filetype(filename=filename)
        } else { 
                format <- dots$format 
        }
        if (is.null(dots$overwrite)) { 
                overwrite <- .overwrite()       
        } else {
                overwrite <- dots$overwrite
        }
        if (is.null(dots$progress)) { 
                progress <- .progress() 
        } else {
                progress <- dots$progress
        }
        if (is.null(dots$datatype)) { 
                datatype <- unique(dataType(x))
                if (length(datatype) > 1) {
                        datatype <- .commonDataType(datatype)
                }
        } else {
                datatype <- dots$datatype
        }

        if (canProcessInMemory(x, length(rasters) + 2)) {

                v <- getValues( rasters[[1]] )
                for (j in 2:length(rasters)) {
                        v[is.na(v)] <- getValues(rasters[[j]])[is.na(v)]
                }       
                outRaster <- setValues(outRaster, v)
                if (filename != '') {
                        outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress )
                }

        } else {

                if (filename == '') { filename <- rasterTmpFile() }
                outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite )
                tr <- blockSize(outRaster, length(rasters))
                pb <- pbCreate(tr$n, progress=progress, label='cover')
                for (i in 1:tr$n) {
                        v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] )
                        if (! is.matrix(v) ) {  v <- matrix(v, ncol=1) }                
                        for (j in 2:length(rasters)) {
                                vv <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i])
                                v[is.na(v)] <- vv[is.na(v)] 
                        }       
                        outRaster <- writeValues(outRaster, v, tr$row[i])
                        pbStep(pb, i) 
                }
                pbClose(pb)
                outRaster <- writeStop(outRaster)
        }
        return(outRaster)
}
)

59 crop.R

# Authors: Robert J. Hijmans and Jacob van Etten
# Date : October 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(crop)) {
        setGeneric(crop, function(x, y, ...)
                standardGeneric(crop))
}       
.copyWithProperties <- function(x) {
        if (inherits(x, 'RasterStackBrick')) {
                out <- brick(x, values=FALSE)   
        } else { 
                out <- raster(x)
                out@legend <- x@legend
        } 
        names(out) <- names(x)
        out <- setZ(out, getZ(x))
        fx <- is.factor(x)
        if (isTRUE(any(fx))) {
                out@data@isfactor <- fx
                out@data@attributes <- levels(x)
        }
        out
}
setMethod('crop', signature(x='Raster', y='ANY'), 
function(x, y, filename='', snap='near', datatype=NULL, ...) {
        filename <- trim(filename)
        y <- try ( extent(y), silent=TRUE )
        if (class(y) == try-error) {
                stop('Cannot get an Extent object from argument y')
        }
        validObject(y)

        out <- .copyWithProperties(x)   
        leg <- out@legend
        e <- intersect(extent(x), extent(y))
        if (is.null(e)) {
                stop('extents do not overlap')
        }
        e <- alignExtent(e, x, snap=snap)
        out <- setExtent(out, e, keepres=TRUE)

        if (! hasValues(x)) {
                return(out)
        }
        col1 <- colFromX(x, xmin(out)+0.5*xres(out))
        col2 <- colFromX(x, xmax(out)-0.5*xres(out))
        row1 <- rowFromY(x, ymax(out)-0.5*yres(out))
        row2 <- rowFromY(x, ymin(out)+0.5*yres(out))
        if (row1==1 & row2==nrow(x) & col1==1 & col2==ncol(x)) {
                return(x)
        }
        nc <- ncol(out)
        nr <- row2 - row1 + 1

        if (is.null(datatype)) { 
                datatype <- unique(c(dataType(x), 'INT2S'))
                if (length(datatype) > 1) {
                        datatype <- .commonDataType(datatype)
                }
        } 
        dataType(out) <- datatype

        xx <- out
        xx@ncols <- x@ncols # getValuesBlock might read entire rows and then subset
        if (canProcessInMemory(xx, 4)) { 
                v <- getValuesBlock(x, row1, nrows=nr, col=col1, ncols=nc)
                out <- setValues(out, v)
                if (filename != ) { 
                        out <- writeRaster(out, filename=filename, datatype=datatype, ...)                      
                }
        } else { 
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='crop', ...)
                out <- writeStart(out, filename=filename, datatype=datatype, ... )
                x <- readStart(x, ...)
                for (i in 1:tr$n) {
                        vv <- getValuesBlock(x, row=tr$row[i]+row1-1, nrows=tr$nrows[i], col1, nc)
                        out <- writeValues(out, vv, tr$row[i])
                        pbStep(pb, i)                   
                } 
                out <- writeStop(out)
                x <- readStop(x)
                pbClose(pb)
        }
        out@legend <- leg
        return(out)
}
)

60 cropSpatial.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
setMethod('crop', signature(x='Spatial', y='ANY'), 
        function(x, y, ...) {

                if (! inherits(y, 'SpatialPolygons')) {
                        if (inherits(y, 'Extent')) {
                                y <- as(y, 'SpatialPolygons')
                                y@proj4string <- x@proj4string
                        } else { 
                                y <- extent(y)
                                validObject(y)
                                y <- as(y, 'SpatialPolygons')
                        }
                        y@proj4string <- x@proj4string          
                }

                if (! compareCRS(x, y) ) {
                        warning('non identical CRS')
                }
                y@proj4string <- x@proj4string

                if (inherits(x, 'SpatialPolygons')) {
                        stopifnot(require(rgeos))
                        .cropSpatialPolygons(x, y, ...)
                } else if (inherits(x, 'SpatialLines')) {
                        stopifnot(require(rgeos))
                        .cropSpatialLines(x, y, ...)
                } else if (inherits(x, 'SpatialPoints')) {
                        .cropSpatialPoints(x, y, ...)
                } else {
                        return( x[y] )
                }
        }
)       
.cropSpatialPolygons <- function(x, y, ...) {

                y <- rgeos::gUnaryUnion(y)
                row.names(y) <- '1'
                rnx <- row.names(x)
                row.names(x) <- as.character(1:length(rnx))

                if (.hasSlot(x, 'data')) {

                        # to keep the correct IDs
                        # in future versions of rgeos, this intermediate step won't be necessary
                        i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) )
                        if (sum(i) == 0) {
                                return(NULL)
                        }
                        y <- rgeos::gIntersection(x[i,], y, byid=TRUE)
                        if (inherits(y, SpatialCollections)) {
                                y <- y@polyobj
                        }
                        if (is.null(y)) { return(y) }

                        ids <- strsplit(row.names(y), ' ') 
                        ids <- as.numeric(do.call(rbind, ids)[,1])
                        row.names(y) <- as.character(rnx[ids])
                        data <- x@data[ids, ,drop=FALSE]
                        rownames(data) <- rnx[ids]

                        return( SpatialPolygonsDataFrame(y, data) )
                } else {
                        y <- rgeos::gIntersection(x, y, drop_not_poly=TRUE)
                        #if (inherits(y, SpatialCollections)) {
                        #       y <- y@polyobj
                        #}
                        return(y)
                }
}
.cropSpatialLines <- function(x, y, ...) {

                rnx <- row.names(x)
                row.names(x) <- as.character(1:length(rnx))
                if (.hasSlot(x, 'data')) {

                        # in future versions of rgeos, this intermediate step should not be necessary
                        i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) )
                        if (sum(i) == 0) {
                                return(NULL)
                        }
                        y <- rgeos::gIntersection(x[i,], y, byid=TRUE)
                        if (inherits(y, SpatialCollections)) {
                                y <- y@lineobj
                        }

                        ids <- strsplit(row.names(y), ' ') 
                        ids <- as.numeric(do.call(rbind, ids)[,1])
                        row.names(y) <- as.character(rnx[ids])
                        data <- x@data[ids, ,drop=FALSE]
                        rownames(data) <- rnx[ids]

                        SpatialLinesDataFrame(y, data)
                } else {
                        y <- rgeos::gIntersection(x, y)
                        if (inherits(y, SpatialCollections)) {
                                y <- y@lineyobj
                        }
                        return(y)
                }
}
.cropSpatialPoints <- function(x, y, ...) {
        i <- which(!is.na(over(x, y)))
        if (length(i) > 0) {
                x <- x[i,]
        } else {
                x <- NULL
        }
        x

}

61 crosstab.R

# Author: Robert J. Hijmans
# Date : March 2009
# Version 1.0
# Licence GPL v3
# revised April 2011
if (!isGeneric(crosstab)) {
        setGeneric(crosstab, function(x, y, ...)
                standardGeneric(crosstab))
}
setMethod('crosstab', signature(x='Raster', y='Raster'), 
        function(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) {
                x <- stack(x, y)
                crosstab(x, digits=digits, long=long, useNA=useNA, progress=progress, ...) 
        }
)
setMethod('crosstab', signature(x='RasterStackBrick', y='missing'), 
        function(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) {
                nl <- nlayers(x)
                if (nl < 2) {
                        stop('crosstab needs at least 2 layers')
                }
                nms <- names(x)

                if (canProcessInMemory(x)) {
                        res <- getValues(x)
                        res <- lapply(1:nl, function(i) round(res[, i], digits=digits))
                        res <- do.call(table, c(res, useNA='always'))
                        res <- as.data.frame(res)

                } else {
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='crosstab', progress=progress)       
                        res <- NULL
                        for (i in 1:tr$n) {
                                d <- getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i])
                                d <- lapply(1:nl, function(i) round(d[, i], digits=digits))
                                d <- do.call(table, c(d, useNA='always'))
                                d <- as.data.frame(d)
                                res <- rbind(res, d)
                                pbStep(pb, i)
                        }
                        pbClose(pb)

                        if (nrow(res) == 0) {
                                res <- data.frame(matrix(nrow=0, ncol=length(nms)+1))
                        } 
                        colnames(res) <- c(nms, 'Freq')

                        if (! useNA ) {
                                i <- which(apply(res, 1, function(x) sum(is.na(x))>0))                          
                                res <- res[-i,  ,drop=FALSE]
                        }

                        # keep NA classes if there are any
                        for (i in 1:(ncol(res)-1)) {
                                if (any(is.na(res[,i]))) {
                                        res[,i] <- factor(res[,i], levels=c(levels(res[,i]), NA), exclude=NULL) 
                                }
                        }
                        f <- eval(parse(text=paste('Freq ~ ', paste(nms , collapse='+'))))
                        res <- xtabs(f, data=res)

                }

                if (long) {
                        if (nrow(res) > 1) {
                                res <- data.frame(res)
                                colnames(res) <- c(nms, 'Freq') 
                                res <- res[res$Freq > 0,  ,drop=FALSE]
                        }
                } 
                return(res)
        }
)
.oldcrosstab <- function(x, y, digits=0, long=FALSE, progress, ...) {
# old function, not used any more       
                compareRaster(c(x, y))
                if (missing(progress)) { progress <- .progress() }
                if (canProcessInMemory(x, 3) | ( inMemory(x) & inMemory(y) )) {
                        res <- table(first=round(getValues(x), digits=digits), second=round(getValues(y), digits=digits), ...) 
                } else {
                        res <- NULL
                        tr <- blockSize(x, n=2)
                        pb <- pbCreate(tr$n, label='crosstab', progress=progress)       
                        for (i in 1:tr$n) {

                                d <- table( round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), round(getValuesBlock(y, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), ...)
                                if (length(dim(d))==1) {
                                        first = as.numeric(names(d))
                                        second = first
                                        d <- matrix(d)
                                } else {
                                        first = as.numeric(rep(rownames(d), each=ncol(d)))
                                        second = as.numeric(rep(colnames(d), times=nrow(d)))
                                }
                                count = as.vector(t(d))
                                res = rbind(res, cbind(first, second, count))
                                pbStep(pb, i)
                        }
                        pbClose(pb)
                        res = xtabs(count~first+second, data=res)
                }

                if (long) {
                        return( as.data.frame(res) )
                } else {
                        return(res)
                }
}

62 cut.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(cut)) {
        setGeneric(cut, function(x, ...)
                standardGeneric(cut))
}       
setMethod('cut', signature(x='Raster'), 
function(x, breaks, ..., filename='', format, datatype='INT2S', overwrite, progress)  {

        if (! hasValues(x) ) { 
                warning('x has no values, nothing to do')
                return(x) 
        }

        filename <- trim(filename)
        if (missing(format)) { format <- .filetype(format=format, filename=filename) } 
        if (missing(overwrite)) { overwrite <- .overwrite()     }
        if (missing(progress)) { progress <- .progress() }
        nl <- nlayers(x)
        if (nl == 1) { out <- raster(x)
        } else { out <- brick(x, values=FALSE) }        

        if (canProcessInMemory(out, n=nl*2 + 2)) {
                if (nl > 1) {
                        values(out) <- apply(getValues(x), 2, function(x) as.numeric(cut(x, breaks=breaks, ...)))
                } else {
                        values(out) <- as.numeric(cut(getValues(x), breaks=breaks, ...))
                }
                if ( filename !=  ) { 
                        out <- writeRaster(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress )
                }
                return(out)

        } else {
                if (filename == '') { filename <- rasterTmpFile() }
                if (length(breaks) == 1) {
                        breaks <- round(breaks)
                        stopifnot(breaks > 1)
                        probs <- c(0, 1:breaks * 1/breaks)
                        breaks <- na.omit(sampleRegular(x, 10000, useGDAL=TRUE))
                        warning('breaks are approximate, based on a sample of ', length(breaks), ' cells that are not NA')
                        breaks <- quantile(, probs, names=FALSE)
                        breaks[1] <- -Inf
                        breaks[length(breaks)] <- Inf
                }

                out <- writeStart(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress )
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, progress=progress, label='cut')
                if (nl > 1) {
                        for (i in 1:tr$n) {
                                res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                res <- apply(res, 2, function(x) as.numeric(cut(x, breaks=breaks, ...)))
                                out <- writeValues(out, res, tr$row[i])
                                pbStep(pb, i)
                        }
                } else {
                        for (i in 1:tr$n) {
                                res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                res <- as.numeric(cut(res, breaks=breaks, ...))
                                out <- writeValues(out, res, tr$row[i])
                                pbStep(pb, i)
                        }
                }

                out <- writeStop(out)
                pbClose(pb)
                return(out)
        }
}
)

63 cv.R

# Author: Robert J. Hijmans 
# Date : October 2008-2011
# Version 1.0
# Licence GPL v3
setGeneric(cv, function(x, ..., aszero=FALSE, na.rm=FALSE)
        standardGeneric(cv))

setMethod('cv', signature(x='ANY'), 
function(x, ..., aszero=FALSE, na.rm=FALSE) {
#  R function to compute the coefficient of variation (expressed as a percentage)
# if there is only a single value, sd = NA. However, one could argue that cv =0. 
# and NA may break the code that receives it.
#The function returns NA if(aszero=FALSE)   else a value of 0 is returned.
        x <- c(x, ...)
        z <- x[!is.na(x)]
        if (length(z) == 0) { 
                return(NA) 
        } else if (na.rm == FALSE & (length(z) < length(x))) { 
                return(NA)       
        } else if (length(z) == 1 & aszero == TRUE) { 
                return(0)
        } else {
                x <- mean(z)
                if (x == 0) {
                        return(NA)
                } else {
                        return(100 * sd(z) / x)
                }
        }       
}
)
setMethod(cv, signature(x='Raster'),
        function(x, ..., aszero=FALSE, na.rm=FALSE){
                dots <- list(...)
                if (length(dots) > 0) {
                        x <- stack(.makeRasterList(x, ...))
                        add <- .addArgs(...)
                } else {
                        add <- NULL
                }
                out <- raster(x)

                if (canProcessInMemory(x)) {
                        x <- cbind(getValues(x), add)
                        x <- setValues(out, apply(x, 1, cv, aszero=aszero, na.rm=na.rm))
                        return(x)
                }
                tr <- blockSize(out)
                pb <- pbCreate(tr$n)
                out <- writeStart(out, filename=)
                for (i in 1:tr$n) {
                        v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add)
                        v <- apply(v, 1, cv, aszero=aszero, na.rm=na.rm)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                writeStop(out)
        }
)

64 dataProperties.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 0.9
# Licence GPL v3
#dataSize <- function(object) {return(object@file@datasize)}
dataSize <- function(object) {
        if (class(object) != 'character'){
                object <- dataType(object)
        }
        return( as.integer (substr(object, 4, 4)) )
}
dataSigned <- function(object) {
        if (class(object) != 'character') { object <- dataType(object) }
        ifelse(substr(object, 5, 5) == 'U', FALSE, TRUE )
}
.shortDataType <- function(object) {
        if (class(object) != 'character') {
                object <- dataType(object)
        }
        return( substr(object, 1, 3)) 
}
dataType <- function(x) {
        if (inherits(x, 'RasterStack')) {
                return(sapply(x@layers, function(x) x@file@datanotation))
        } else {
                return(x@file@datanotation)
        }
}
..dataIndices <- function(object) {
#       return(object@data@indices)
}
fromDisk <- function(x) {
        if (inherits( x, 'RasterStack' )) {
                return( all( sapply( x@layers, function(x) x@data@fromdisk )))
        } else {
                return( x@data@fromdisk )
        }
}

inMemory <- function(x) {
        if (inherits( x, 'RasterStack' )) {
                return( all( sapply( x@layers, function(x) x@data@inmemory )))
        } else {
                return( x@data@inmemory )
        }
}
hasValues <- function(x) {
        if (class(x) == 'BasicRaster') { return(FALSE) }
        if (inherits(x, 'RasterStack')) { 
                if (nlayers(x) > 0) return(TRUE) else return(FALSE)
        }
        if ( fromDisk(x)  | inMemory(x) ) {
                return(TRUE)
        } else {
                return(FALSE)
        }
}

65 dataType.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
'dataType<-' <- function(x, value) {
        if (inherits(x, 'RasterStack')) {
                stop('Cannot set datatype of a RasterStack')
        }
# for backward compatibility issues and non fatal mistakes.
        datatype <- substr( toupper( trim(value) ), 1, 5)
        if (datatype == 'LOGIC') {datatype <- 'LOG1S'
        } else if (datatype == 'BYTE') {datatype <- 'INT1U'
        } else if (datatype == 'SMALL') {datatype <- 'INT2S'
        } else if (datatype == 'INTEG') {datatype <- 'INT2S'
        } else if (datatype == 'NUMER') {datatype <- 'FLT4S'
        } else if (datatype == 'FLOAT') {datatype <- 'FLT4S'
        } else if (datatype == 'DOUBL') {datatype <- 'FLT8S'
        } else if (datatype == 'SINGL') {datatype <- 'FLT4S'
        } else if (datatype == 'REAL') {datatype <- 'FLT4S'}    

        if (nchar(datatype) < 3) {
                stop(paste('invalid datatype:', datatype))
        } else if (nchar(datatype) == 3) {
                if (datatype == 'LOG') { 
                        datatype <- paste(datatype, '1S', sep='')               
                } else {
                        datatype <- paste(datatype, '4S', sep='') 
                }
        } else if (nchar(datatype) == 4) {
                if (datatype == 'INT1') { 
                        datatype <- paste(datatype, 'U', sep='') 
                } else { 
                        datatype <- paste(datatype, 'S', sep='')
                }
        }
# now for real

        if (!(substr(datatype, 1, 4) %in% c('LOG1', 'INT1', 'INT2', 'INT4', 'FLT4', 'FLT8'))) {
                stop('not a valid data type')
        }
        type <- substr(datatype,1,3)
        size <- substr(datatype,4,4)
        signed <- substr(datatype,5,5) != 'U'

        if (type == FLT) {
#               if (dataContent(x) != 'nodata') { 
#                       x@data@values[] <- as.numeric(x@data@values)
#               }
                if (size == '4') {
                        x@file@datanotation <- 'FLT4S'
                        x@file@nodatavalue <- -3.4E38
                } else if (size == '8') {
                        x@file@datanotation <- 'FLT8S'
                        x@file@nodatavalue <-  -1.7E308
                } else { 
                        stop(invalid datasize for a FLT (should be 4 or 8)) 
                }
        } else if (type == INT) {
#               x@data@min <- round(x@data@min)
#               x@data@max <- round(x@data@max)
#               if (dataContent(x) != 'nodata') { 
#                               x@data@values[] <- as.integer(round(x@data@values))
#                       }                  
#               }

                if (size == '4') {
                        if (signed) {
                                x@file@datanotation <- 'INT4S'
                                x@file@nodatavalue <- -2147483647
                        } else {
                                x@file@datanotation <- 'INT4U'
                                x@file@nodatavalue <- 4294967295
                        }
                } else if (size == '2') {
                        if (signed) {
                                x@file@datanotation <- 'INT2S'
                                x@file@nodatavalue <- -32768
                        } else {
                                x@file@datanotation <- 'INT2U'
                                x@file@nodatavalue <- 65535
                        }
                } else if (size == '1') {
                        if (signed) {
                                x@file@datanotation <- 'INT1S'
                                x@file@nodatavalue <- as.double(NA)  # no default NA value
                        } else {
                                x@file@datanotation <- 'INT1U'
                                x@file@nodatavalue <- as.double(NA)  # no default NA value
                        }
#               } else if (size == '8') {
#                       x@file@nodatavalue <- -9223372036854775808
#                       x@file@datanotation <- 'INT8S'                                                  
                } else {
                        stop(invalid datasize for this datatype) 
                }
        } else if ( type == 'LOG' ) {
                x@file@nodatavalue <- -128
                x@file@datanotation <- 'LOG1S'
        } else {
                stop(unknown datatype)
        } 
        return(x)
}

66 density.R

# Author: Robert J. Hijmans
# Date: December 2009
# Version 0.1
# Licence GPL v3
if (!isGeneric(density)) {
        setGeneric(density, function(x, ...)
                standardGeneric(density))
}       
setMethod('density', signature(x='Raster'), 
        function(x, layer, maxpixels=100000, plot=TRUE, main, ...) {
                if (nlayers(x)==1) {
                        d <- sampleRegular(x, maxpixels, useGDAL=TRUE)
                        x <- density(na.omit(d))
                        if (plot) {
                                if (missing(main)) {
                                        main=''
                                }
                                plot(x, main=main, ...)
                                return(invisible(x))
                        } else {
                                return(x)
                        }
                }

                if (missing(layer)) {
                        y <- 1:nlayers(x)
                } else if (is.character(layer)) {
                        y <- match(layer, names(x))
                } else {
                        y <- layer
                }
                y <- unique(as.integer(round(y)))
                y <- na.omit(y)
                y <- y[ y >= 1 & y <= nlayers(x) ]
                nl <- length(y)
                if (nl == 0) {stop('no existing layers selected')}

                if (nl > 1)     {
                        res <- list()
                        if (nl > 16) {
                                warning('only the first 16 layers are plotted')
                                nl <- 16
                                y <- y[1:16]
                        }
                        if (missing(main)) {
                                main=names(x) 
                        }
                        nc <- ceiling(sqrt(nl))
                        nr <- ceiling(nl / nc)


                        mfrow <- par(mfrow)
                        spots <- mfrow[1] * mfrow[2]
                        if (spots < nl) {
                                old.par <- par(no.readonly = TRUE) 
                                on.exit(par(old.par))
                                par(mfrow=c(nr, nc))
                        }
                        for (i in 1:length(y)) {        
                                r <- raster(x, y[i])
                                m <- main[y[i]]
                                res[[i]] <- density(r, maxpixels=maxpixels, main=m, plot=plot, ...)
                        }               
                } else if (nl==1) {
                        if (missing(main)) {
                                main <- names(x)[y]
                        }
                        r <- raster(x, y)
                        res <- density(r, maxpixels=maxpixels, main=main, plot=plot, ...)
                }
                if (plot) return(invisible(res))
                else return(res)
        }
)

67 destair.R

.destair <- function(x, keepExtent=TRUE) {
        pts <- as.data.frame(as(x, 'SpatialPolygons'), xy=TRUE, centroids=FALSE)

        if (keepExtent) {
                bb <- bbox(x)
                ptsx1 <- pts[,5] == bb[1,1] 
                ptsx2 <- pts[,5] == bb[1,2] 
                ptsy1 <- pts[,6] == bb[2,1] 
                ptsy2 <- pts[,6] == bb[2,2] 
        }

        u <- unique(pts$cump)
        for (j in u) {
                k <- pts$cump==j
                p <- pts[k, 5:6]
                p <- rbind(p[(nrow(p)-1), ,drop=FALSE], p, p[2,,drop=FALSE])
                dx <- diff(p$x)
                dy <- diff(p$y)
                tf1 <- rowSums( cbind(dx[-length(dx)], dy[-1]) )
                tf2 <- rowSums( cbind(dx[-1], dy[-length(dy)]) )
                i <- which(tf1==0 | tf2==0) + 1
                p[i, ] <- (p[i-1, ] + p[i+1, ] + 2 * p[i, ]) / 4
                pts[k, 5:6] <- p[-c(1, nrow(p)),]
        }
        if (keepExtent) {
                pts[ptsx1,5] <- bb[1,1]
                pts[ptsx2,5] <- bb[1,2]
                pts[ptsy1,6] <- bb[2,1]
                pts[ptsy2,6] <- bb[2,2]
        }

        r <- as(pts, 'SpatialPolygons')
        row.names(r) <- row.names(x)
        proj4string(r) <- proj4string(x)

        if (.hasSlot(x, 'data')) {
                r <- SpatialPolygonsDataFrame(r, x@data)
        }

        r
}

68 detectCores.R

#  File src/library/parallel/R/detectCores.R
#  Part of the R package, http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/
## In part based on code in package multicore 0.1-6 by Simon Urbanek
.detectCores <-
    if(.Platform$OS.type == windows) {
                function(all.tests = FALSE, logical = TRUE) {
                        # This is a hack to stop the check NOTE: .detectCores: no visible global function definition for 'readRegistry'
                        if (!exists('readRegistry')) { readRegistry <- function(...)(1) } 

                        length(readRegistry(HARDWARE\\DESCRIPTION\\System\\CentralProcessor, maxdepth=1))
                }
    } else {
        function(all.tests = FALSE, logical = FALSE) {
            systems <-
                list(darwin = /usr/sbin/sysctl -n hw.ncpu 2>/dev/null,
                     freebsd = /sbin/sysctl -n hw.ncpu 2>/dev/null,
                     linux = grep processor /proc/cpuinfo 2>/dev/null | wc -l,
                     irix  = c(hinv | grep Processors | sed 's: .*::',
                     hinv | grep '^Processor '| wc -l),
                     solaris = if(logical) /usr/sbin/psrinfo -v | grep 'Status of.*processor' | wc -l else /bin/kstat -p -m cpu_info | grep :core_id | cut -f2 | uniq | wc -l)
            for (i in seq(systems))
                if(all.tests ||
                   length(grep(paste(^, names(systems)[i], sep=''),
                               R.version$os)))
                    for (cmd in systems[i]) {
                        a <- gsub(^ +,, system(cmd, TRUE)[1])
                        if (length(grep(^[1-9], a))) return(as.integer(a))
                    }
            NA_integer_
        }
    }

69 dim.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 0.9
# Licence GPL v3
setMethod('dim', signature(x='BasicRaster'), 
        function(x){ return(c(nrow(x), ncol(x), 1)) }
)
setMethod('dim', signature(x='RasterStackBrick'), 
        function(x){ return(c(nrow(x), ncol(x), nlayers(x))) }
)
setMethod('nrow', signature(x='BasicRaster'), 
        function(x){ return(x@nrows)}
)
setMethod('ncol', signature(x='BasicRaster'), 
        function(x){ return(x@ncols) }
)
setMethod('dim<-', signature(x='BasicRaster'), 
        function(x, value) {

                if (length(value) == 1) {
                        value <- c(value, ncol(x))
                } 
                value <- as.integer(pmax(round(value[1:2]), c(1,1)))
                x@nrows <- value[1]
                x@ncols <- value[2]

                return(x)       
        }
)
setMethod('dim<-', signature(x='RasterLayer'), 
        function(x, value) {

                if (length(value) == 1) {
                        value <- c(value, ncol(x))
                } else if (length(value) > 2) {
                        value <- value[1:2]
                }

                value <- as.integer(pmax(round(value), c(1,1)))

                if (value[1] != nrow(x) | value[2] != ncol(x)) {
                        x <- clearValues(x)
                        x <- .clearFile(x)
                        x@nrows <- value[1]
                        x@ncols <- value[2]
                }
                return(x)       
        }
)
setMethod('dim<-', signature(x='RasterBrick'), 
        function(x, value) {

                if (length(value) == 1) {
                        value <- c(value, ncol(x), nlayers(x))
                } else if (length(value) == 2) {
                        value <- c(value, nlayers(x))
                } else if (length(value) > 3) {
                        warning('value should have length 1, 2, or 3. Additional values ignored')
                        value <- value[1:3]
                }

                value <- as.integer(pmax(round(value), c(1,1,1)))

                if (value[1] != nrow(x) | value[2] != ncol(x) | value[3] != nlayers(x)) {
                        x <- clearValues(x)
                        x <- .clearFile(x)
                        x@nrows <- value[1]
                        x@ncols <- value[2]
                        x@data@nlayers <- value[3]
                }
                return(x)       
        }
)

70 direction.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2009
# revised October 2011
# Version 1.0
# Licence GPL v3
if (!isGeneric(direction)) {
        setGeneric(direction, function(x, ...)
                standardGeneric(direction))
}       
setMethod('direction', signature(x='RasterLayer'), 
function(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) {
        out <- raster(x)
        if (couldBeLonLat(out)) { 
                longlat=TRUE 
        } else { 
                longlat=FALSE 
        }
        longlat <- as.integer(longlat)
        degrees <- as.integer(degrees)
        from <- as.integer(from)

        if (doEdge) {
                r <- boundaries(x, classes=FALSE, type='inner', asNA=TRUE, progress=.progress(...)) 
                pts <- try(  rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] )
        } else {
                pts <- try(  rasterToPoints(x)[,1:2, drop=FALSE] )
        }
        if (class(pts) == try-error) {
                stop('This function has not yet been implemented for very large files')
        }
        if (nrow(pts) == 0) {
                stop('RasterLayer has no NA cells (for which to compute a direction)')
        }

        filename <- trim(filename)
        if ( canProcessInMemory(out, 3)) {
                vals <- getValues(x)
                i <- which(is.na(vals))
                xy <- xyFromCell(out, i)
                vals[] <- NA
                vals[i] <- .Call('directionToNearestPoint', xy, pts, longlat, degrees, from, PACKAGE='raster')
                out <- setValues(out, vals)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                }
                return(out)
        }

        out <- writeStart(out, filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='direction', ...)
        xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA)
        for (i in 1:tr$n) {
                if (i == tr$n) {
                        xy <- xy[1:(ncol(out)*tr$nrows[i]), ]
                }
                xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out))
                vals <- getValues(x, tr$row[i], tr$nrows[i])
                j <- which(is.na(vals))
                vals[] <- NA
                if (length(j) > 0) {
                        vals[j] <- .Call(directionToNearestPoint, xy[j, ,drop=FALSE], pts, longlat, degrees, from, PACKAGE='raster')
                }
                out <- writeValues(out, vals, tr$row[i])
                pbStep(pb)      
        }       
        pbClose(pb)
        out <- writeStop(out)
        return(out)
}
)

71 disaggregate.R

# Author: Robert Hijmans
# Date : October 2008 - December 2011
# Version 1.0
# Licence GPL v3
# April 2012: Several patches & improvements by Jim Regetz
if (!isGeneric(disaggregate)) {
        setGeneric(disaggregate, function(x, ...)
                standardGeneric(disaggregate))
}
setMethod('disaggregate', signature(x='Raster'), 
function(x, fact=NULL, method='', filename='', ...) {
        method <- tolower(method)
        if (!method %in% c('bilinear', '')) {
                stop('unknown method. Should be bilinear or ')
        }

        stopifnot(!is.null(fact))
        fact <- as.integer(round(fact))
        if (length(fact)==1) {
                if (fact == 1)  return(x) 
                if (fact < 2) { stop('fact should be >= 1') }
                xfact <- yfact <- fact
        } else if (length(fact)==2) {
                xfact <- fact[1]
                yfact <- fact[2]
                if (xfact < 1) { stop('fact[1] should be > 0') } 
                if (yfact < 1) { stop('fact[2] should be > 0') }
                if (xfact == 1 & yfact == 1) { return(x) }
        } else {
                stop('length(fact) should be 1 or 2')
        }
        filename <- trim(filename)
        nl <- nlayers(x)
        if (nl > 1) {
                out <- brick(x, values=FALSE)
        } else {
                out <- raster(x)
        }
        ncx <- ncol(x)
        nrx <- nrow(x)
        dim(out) <- c(nrx * yfact, ncx * xfact) 
        names(out) <- names(x)

        if (! inherits(x, 'RasterStack')) {
                if (! inMemory(x)  & ! fromDisk(x) ) {
                        return(out)
                }
        }

        if (method=='bilinear') {
                return(resample(x, out, method='bilinear', filename=filename, ...))
        } 



        if (canProcessInMemory(out, 3)) { 
                x <- getValues(x)
                cols <- rep(seq.int(ncx), each=xfact)
                rows <- rep(seq.int(nrx), each=yfact)
                cells <- as.vector( outer(cols, ncx*(rows-1), FUN=+) )
                if (nl > 1) {
                        x <- x[cells, ]                 
                } else {
                        x <- x[cells]                   
                }
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename=filename,...)
                }

        } else { 

                tr <- blockSize(x, n=nlayers(x) * prod(fact))
                rown <- (tr$row-1) * yfact + 1
                pb <- pbCreate(tr$n, label='disaggregate', ...)
                if (is.null(list(...)$datatype)) {
                        out <- writeStart(out, filename=filename, datatype=.commonDataType(dataType(x)), ...)
                } else {                
                        out <- writeStart(out, filename=filename, ...)
                }
                x <- readStart(x, ...)          

                cols <- rep(seq.int(ncx), each=xfact)
                rows <- rep(seq.int(tr$nrows[1]), each=yfact)
                cells <- as.vector( outer(cols, ncx*(rows-1), FUN=+) )
                for (i in 1:tr$n) {
                        if (i == tr$n) {
                                if (tr$nrows[i] != tr$nrows[1]) {
                                        rows <- rep(seq.int(tr$nrows[i]), each=yfact)
                                        cells <- outer(cols, ncx*(rows-1), FUN=+)
                                }
                        }
                        v <- getValues(x, tr$row[i], tr$nrows[i])
                        if (nl > 1) {
                                v <- v[cells, ]
                        } else {
                                v <- v[cells]                   
                        }
                        out <- writeValues(out, v, rown[i])
                        pbStep(pb, i)
                }

                out <- writeStop(out)
                x <- readStop(x)
                pbClose(pb)                     

        }
        return(out)
}
)

72 distanceFromPoints.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2009
# Version 0.9
# Licence GPL v3
distanceFromPoints <- function(object, xy, filename='', ...) {

        pts <- .pointsToMatrix(xy)
        rm(xy)
        filename <- trim(filename)

        if (couldBeLonLat(object)) { 
                longlat=TRUE 
        } else { 
                longlat=FALSE 
        }

        out <- raster(object)
        if (canProcessInMemory(out, 4)) {
                xy <- xyFromCell(out, 1:ncell(out))
                out <- setValues(out, .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster'))
                if (filename != '') {
                        out <- writeRaster(out, filename=filename, ...)
                }
                return(out)
        } 

        out <- writeStart(out, filename=filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, ...)
        xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA)
        for (i in 1:tr$n) {
                if (i == tr$n) {
                        xy <- xy[1:(ncol(out)*tr$nrows[i]), ]
                }
                xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out))
                vals <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster')
                out <- writeValues(out, vals, tr$row[i])
                pbStep(pb)      
        }       
        pbClose(pb)
        out <- writeStop(out)
        return(out)
}

73 distance.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(distance)) {
        setGeneric(distance, function(x, ...)
                standardGeneric(distance))
}       
setMethod('distance', signature(x='RasterLayer'), 
function(x, filename='', doEdge=TRUE, ...) {
        if (doEdge) {
                r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) 
                pts <- try(  rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] )
        } else {
                pts <- try(  rasterToPoints(x)[,1:2, drop=FALSE] )
        }

        if (class(pts) == try-error) {
                return( .distanceRows(x, filename=filename, ...) )
        }
        if (nrow(pts) == 0) {
                stop('RasterLayer has no NA cells (for which to compute a distance)')
        }
        out <- raster(x)
        filename <- trim(filename)

        if (couldBeLonLat(x)) { 
                longlat=TRUE 
        } else { 
                longlat=FALSE 
        }

        if (canProcessInMemory(out, 6)) {
                pb <- pbCreate(3, label='distance', ...)
                x <- values(x)
                i <- which(is.na(x))
                if (length(i) < 1) {
                        stop('raster has no NA values to compute distance to')
                }
                pbStep(pb)
                x[] <- 0
                xy <- xyFromCell(out, i)
                x[i] <- .Call(distanceToNearestPoint, xy, pts, as.integer(longlat), PACKAGE='raster')
                pbStep(pb)
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename=filename, ...)
                }
                pbStep(pb)
                pbClose(pb)
                return(out)
        } 

        out <- writeStart(out, filename=filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='distance', ...)
        xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA)
        for (i in 1:tr$n) {
                if (i == tr$n) {
                        xy <- xy[1:(ncol(out)*tr$nrows[i]), ]
                }
                xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out))
                vals <- getValues(x, tr$row[i], tr$nrows[i])
                j <- which(is.na(vals))
                vals[] <- 0
                if (length(j) > 0) {
                        vals[j] <- .Call(distanceToNearestPoint, xy[j,,drop=FALSE], pts, as.integer(longlat), PACKAGE='raster')
                }
                out <- writeValues(out, vals, tr$row[i])
                pbStep(pb)      
        }       
        pbClose(pb)
        out <- writeStop(out)
        return(out)
}
)

74 distanceRows.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2009
# Version 0.9
# Licence GPL v3
.distanceRows <- function(object, filename, progress='', ...) {
        filename <- trim(filename)
        overwrite <- .overwrite(...)
        if( (!overwrite) & file.exists(filename)) {
                stop('file exists; use overwrite=TRUE to overwrite it')
        }
        if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE }
        e <- boundaries(object, classes=FALSE, type='inner', asNA=TRUE) 

        r <- raster(object)
        tr <- blockSize(r, n=3)
        tmp = rasterTmpFile()
        extension(tmp) = '.tif'

        .requireRgdal()
        r <- writeStart(r, filename=tmp, format='GTiff')

        pb <- pbCreate(tr$n, progress=progress)                 
        xx <- xFromCol( r, 1:ncol(r) )

        hasWritten=FALSE
        for (i in 1:tr$n) {
        # get the from points for a block
                v <- getValuesBlock(e, row=tr$row[i], nrows=tr$nrows[i])
                x <- rep(xx, tr$nrows[i])
                y <- yFromRow(r, tr$row[i]) - (0:(tr$nrows[i]-1)) * yres(r)
                y <- rep(y, each=ncol(r))
                xyv <- cbind(x,y,v)
                from <- na.omit(xyv)[,1:2]
                if (isTRUE(nrow(from)==0)) {
                        pbStep(pb, i)                   
                        next
                }
                for (j in 1:tr$n) {
                        # distance to these points for all blocks
                        x <- rep(xx, tr$nrows[j])
                        y <- yFromRow(r, tr$row[j]) - (0:(tr$nrows[j]-1)) * yres(r)
                        y <- rep(y, each=ncol(r))
                        v <- getValuesBlock(object, row=tr$row[j], nrows=tr$nrows[j])
                        xyv <- cbind(x,y,v)
                        to <- xyv[is.na(xyv[,3]), 1:2]
                        v[] = 0
                        if ( isTRUE(nrow(to) > 0) ) {
                                v[is.na(xyv[,3])] <- .Call(distanceToNearestPoint, to, from, as.integer(longlat), PACKAGE='raster')
                        }                       
                        if (hasWritten) {
                                # after the first round, compare new values with previously written values
                                v <- pmin(v, .getTransientRows(r, tr$row[j], n=tr$nrows[j])) 
                        } 
                        r <- writeValues(r, v, tr$row[j])                       
                }
                hasWritten = TRUE
                pbStep(pb, i)                   
        }
        r <- writeStop(r)
        pbClose(pb)

        r <- writeRaster(r, filename=filename, ...)
        return(r)
}

75 dotdens.R

# Robert Hijmans
# Based on maptools:dotsInPolys by Roger Bivand
.dotdensity <- function(p, field, x=1, type=regular, seed=0,...) {
        set.seed(seed)
        stopifnot(inherits(p, 'SpatialPolygons'))
    n <- length(p)
    if (n < 1) return(invisible(NULL))
        f <- tolower(type)
        stopifnot(type %in% c('regular', 'random'))  
        if (inherits(p, 'SpatialPolygonsDataFrame')) {
                if (is.numeric(field)) {
                        if (length(field)==1) {
                                field <- round(field)
                                stopifnot(field > 0 & field <= ncol(p))
                                field <- p@data[, field]
                        } else {
                                stopifnot(length(field)==length(p))
                        }
                } else if (is.character(field)) {
                        stopifnot(field %in% names(p))
                        field <- p@data[, field]
                }
        } else {
                stopifnot(is.numeric(field))
                stopifnot(length(field)==length(p))
        }
        x <- x[1]
        stopifnot(x > 0)
        d <- round(field / x)
        d[d < 1] <- 0
        d[is.na(d)] <- 0

    res <- vector(mode = list, length = n)
    for (i in 1:n) {
                if (d[i] > 0) {
                        ires <- try (spsample(p[i, ], d[i], type=f), silent=TRUE  )
                        if (class(ires) == 'try-error') {
                                print(paste('error, ', d[i]))
                                ires <- NULL
                        }
                        if (!is.null(ires)) {
                                res[[i]] <- cbind(coordinates(ires), id=i)
                        }
                }
    }
    do.call(rbind, res)
}

76 drawExtent.R

# R function for the raster package
# Author: Robert J. Hijmans
# Date : January 2009, December 2011
# Version 1.0
# Licence GPL v3
drawExtent <- function(show=TRUE, col=red) {
        if (show) {
                loc1 <- locator(n=1, type=p, pch='+', col=col)
        } else {
                loc1 <- locator(n=1)    
        }
        loc2 <- locator(n=1)
        loc <- rbind(unlist(loc1), unlist(loc2))
        e <- extent(min(loc[,'x']), max(loc[,'x']), min(loc[,'y']), max(loc[,'y']))
        if (e@xmin == e@xmax) {
                e@xmin <- e@xmin - 0.0000001
                e@xmax <- e@xmax + 0.0000001
        }
        if (e@ymin == e@ymax) {
                e@ymin <- e@ymin - 0.0000001
                e@ymax <- e@ymax + 0.0000001
        }
        if (show) {
                p <- rbind(c(e@xmin, e@ymin), c(e@xmin, e@ymax), c(e@xmax, e@ymax), c(e@xmax, e@ymin), c(e@xmin, e@ymin) )
                lines(p, col=col)
        }
        return(e)
}

77 drawPoly.R

# R function for the raster package
# Author: Robert J. Hijmans
# contact: r.hijmans@gmail.com
# Date : January 2009
# Version 0.9
# Licence GPL v3
drawPoly <- function(sp=TRUE, col='red', lwd=2, ...) {
        xy <- locator(n=10000, type=l, col=col, lwd=lwd, ...)
        xy <- cbind(xy$x, xy$y)
        xy <- rbind(xy, xy[1,])
        lines(xy[(length(xy[,1])-1):length(xy[,1]),], col=col, lwd=lwd, ...)
        if (sp) {
                return( SpatialPolygons(list(Polygons(list(Polygon(xy)), 1))) )
        } else {
                return(xy)
        }
}
drawLine <- function(sp=TRUE, col='red', lwd=2, ...) {
        xy <- locator(n=10000, type=l, col=col, lwd=lwd, ...)
        xy <- cbind(xy$x, xy$y)
        if (sp) {
                return( SpatialLines(list(Lines(list(Line(xy)), 1))) )
        } else {
                return(xy)
        }
}

78 drivers.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  November 2008
# Version 0.9
# Licence GPL v3
.nativeDrivers <- function() {
        return(  c(raster, SAGA, IDRISI, IDRISIold, BIL, BSQ, BIP) )
}
.nativeDriversLong <- function() {
        return(  c(R-raster, SAGA GIS, IDRISI, IDRISI (img/doc), Band by Line, Band Sequential, Band by Pixel) )
}
.isNativeDriver <- function(d) {
        return( d %in% .nativeDrivers() ) 
}
writeFormats <- function() {
        if ( .requireRgdal(FALSE) ) {
                gd <- .gdalWriteFormats() 
                short <- c(.nativeDrivers(),  'ascii', 'CDF', 'big', as.vector(gd[,1]))
                long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', 'big.matrix', as.vector(gd[,2]))
        } else {
                short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', )
                long <- c(.nativeDriversLong(), Arc ASCII, NetCDF, big.matrix, , rgdal not installed)
        }

        m <- cbind(short, long)
        colnames(m) <- c(name, long_name)
        return(m)
}

79 dropLayer.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : June 2008
# Version 0.9
# Licence GPL v3

 if (!isGeneric(dropLayer)) {
        setGeneric(dropLayer, function(x, i, ...)
                standardGeneric(dropLayer))
}

...nameToIndex <- function(name, allnames) {
        # this is the same as match, I think
        k = NULL
        for (i in 1:length(name)) {
                k = c(k, which(allnames == name[i])[1])
        }
        return(k)
}


setMethod('dropLayer', signature(x='RasterStack'), 
function(x, i, ...) {
        if (is.character(i)) {
                i = match(i, names(x))
        }
        i <- sort(unique(round(i)))
        i <- i[i > 0 & i <= nlayers(x)]
        if (length(i) > 0) {
                x@layers <- x@layers[-i]
        }
        return(x)
}
)
setMethod('dropLayer', signature(x='RasterBrick'), 
function(x, i, ...) {
        if (is.character(i)) {
                i <- match(i, names(x))
        }
        i <- sort(unique(round(i)))
        nl <- nlayers(x)
        i <- i[i > 0 & i <= nl]
        if (length(i) < 1) {
                return(x)
        } else {
                sel <- which(! 1:nl %in% i )
                if (length(sel) == 0) {
                        return(brick(x, values=FALSE))
                } else {
                        return(subset(x, sel, ...))
                }
        }
}
)

80 erase.R

if (!isGeneric(erase)) {
        setGeneric(erase, function(x, y, ...)
                standardGeneric(erase))
}       
.gDif <- function(x, y) {
        xln <- length(x@polygons)
        yln <- length(y@polygons)
        if (xln==0 | yln==0) {
                return(x)
        }
        rn <- row.names(x)
        for (i in xln:1) {
                z <- x[i,]
                for (j in 1:yln) {
                        z <- rgeos::gDifference(z, y[j,])
                        if (is.null(z)) {
                                break
                        }
                }
                if (is.null(z)) {
                        x <- x[-i,]
                        rn <- rn[-i]
                } else {
                        x@polygons[i] <- z@polygons
                }
        }
        if (length(rn) > 0) {
                row.names(x) <- rn
        }
        x
}
setMethod(erase, signature(x='SpatialPolygons', y='SpatialPolygons'),
    function(x, y, ...){ 

                require(rgeos)
                if (! identical(x@proj4string, y@proj4string) ) {
                        warning('non identical CRS')
                        y@proj4string <- x@proj4string
                }

                if (!.hasSlot(x, 'data')) {
                        d <- data.frame(ID=1:length(x@polygons))
                        rownames(d) <- row.names(x)
                        x <- SpatialPolygonsDataFrame(x, data=d)
                        dropframe <- TRUE
                } else {
                        dropframe <- FALSE
                }
                y <- aggregate(y)

                int <- rgeos::gIntersects(x, y, byid=TRUE)
                int1 <- apply(int, 2, any)
                int2 <- apply(int, 1, any)

                if (sum(int1) == 0) { # no intersections
                        return(x)
                }

                if (all(int1)) {
                        part1 <- NULL
                } else {
                        part1 <- x[!int1,]
                }
                part2 <- .gDif(x[int1,], y[int2,])
                part2 <- SpatialPolygonsDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE])
                if (!is.null(part1)) {
                        part2 <- rbind(part1, part2)
                }

                if (length(part2@polygons) > 1) {       
                        part2 <- aggregate(part2, v=colnames(part2@data))
                }
                if (dropframe) {
                        return( as(part2, 'SpatialPolygons') )
                } else {
                        return( part2 )
                }
        }
)

81 extend.R

# Author: Robert J. Hijmans
# Date : October 2008
# Licence GPL v3
# revised November 2011
# version 1.0
if (!isGeneric(extend)) {
        setGeneric(extend, function(x, y, ...)
                standardGeneric(extend))
}       
setMethod('extend', signature(x='Extent'), 
# function by Etienne B. Racine
function(x, y, ...) {
        if (length(y) == 1) {
                y <- rep(y, 4)
        } else if (length(y) == 2) {
                y <- rep(y, each=2)
        } else if (! length(y) == 4 ) {
                stop('argument y should be a vector of 1, 2, or 4 elements')    
        }
        x@xmin <- x@xmin - y[1]
        x@xmax <- x@xmax + y[2]
        x@ymin <- x@ymin - y[3]
        x@ymax <- x@ymax + y[4]
        validObject(x)
        x
}
)
setMethod('extend', signature(x='Raster'), 
function(x, y, value=NA, filename='', ...) {
        if (is.vector(y)) {
                if (length(y) <= 2) {
                        adj <- abs(y) * rev(res(x))
                        y <- extent(x)
                        y@ymin <- y@ymin - adj[1]
                        y@ymax <- y@ymax + adj[1]
                        y@xmin <- y@xmin - adj[2]
                        y@xmax <- y@xmax + adj[2]
                }
        }

        test <- try ( y <- extent(y), silent=TRUE )
        if (class(test) == try-error) {
                stop('Cannot get an Extent object from argument y')
        }
        filename <- trim(filename)

        y  <- alignExtent(y, x)
# only expanding here, not cropping
        y <- union(y, extent(x))

        if (nlayers(x) <= 1) {
                out <- raster(x)
                leg <- x@legend
        } else {
                out <- brick(x, values=FALSE)   
                leg <- new('.RasterLegend')
        }
        out@data@names <- names(x)
        out <- setExtent(out, y, keepres=TRUE)
        if (is.factor(x)) {
#               if (is.na(value)) {
                        levels(out) <- levels(x)
#               }       
        }

        if (nrow(x) == nrow(out) & ncol(x) == ncol(out)) {
                # nothing to do.
                return(x)
        }
        if (! hasValues(x) ) {
                return(out)
        }

        dtp <- FALSE
        datatype <- list(...)$datatype
        if (is.null(datatype)) { 
                datatype <- unique(dataType(x))
                if (length(datatype) > 1) {
                        datatype <- .commonDataType(datatype)
                }
                dtp <- TRUE
        }

        if (canProcessInMemory(out)) {

                d <- matrix(value, nrow=ncell(out), ncol=nlayers(x))
                d[cellsFromExtent(out, extent(x)), ] <- getValues(x)
                x <- setValues(out, d)  
                if (filename != '') {
                        if (dtp) {
                                x <- writeRaster(x, filename=filename, datatype=datatype, ...)
                        } else {
                                x <- writeRaster(x, filename=filename, ...)
                        }
                }
                return(x)

        } else { 

                startrow <- rowFromY(out, yFromRow(x, 1))
                endrow <- rowFromY(out, yFromRow(x, nrow(x)))
                startcol <- colFromX(out, xFromCol(x, 1))
                endcol <- colFromX(out, xFromCol(x, ncol(x)))

                tr <- blockSize(out)
                tr$row <- sort(unique(c(tr$row, startrow, endrow+1)))
                tr$nrows <- c(tr$row[-1], nrow(out)+1) - tr$row
                tr$n <- length(tr$row)

                pb <- pbCreate(tr$n, label='extend', ...)
                if (dtp) {
                        out <- writeStart(out, filename=filename, datatype=datatype, ... )
                } else {
                        out <- writeStart(out, filename=filename, ... )         
                }
                for (i in 1:tr$n) {
                        d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out))
                        if (tr$row[i] <= endrow & (tr$row[i]+tr$nrows[i]-1) >= startrow) {
                                cells <- startcol:endcol + rep((0:(tr$nrows[i]-1)) * ncol(out), each=endcol-startcol+1)
                                d[cells, ] <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i])
                        }
                        out <- writeValues(out, d, tr$row[i])
                        pbStep(pb, i)                   
                }

                pbClose(pb)
                out <- writeStop(out)
                return(out)
        } 
}
)

82 extension.R

# return or change file extensions
# Author: Robert J. Hijmans
# Date : October 2008
# Version 1.0
# Licence GPL v3
extension <- function(filename, value=NULL, maxchar=10) {
        if (!is.null(value)) {
                extension(filename) <- value
                return(filename)
        }   
        lfn <- nchar(filename)
        ext <- list()
        for (f in 1:length(filename)) {
                extstart <- -1
                for (i in lfn[f] : 2) {
                        if (substr(filename[f], i, i) == .) {
                                extstart <- i
                                break
                        }
                }
                if (extstart > 0) {
                        ext[f] <- substr(filename[f], extstart, lfn[f])
                } else { 
                        ext[f] <-  
                }   
        }
        ext <- unlist(ext)
        ext[nchar(ext) > maxchar] <- ''
        return(ext)
}   
'extension<-' <- function(filename, value) {
        value <- trim(value)
        if (value !=  & substr(value, 1, 1) != .) {
                value <- paste(., value, sep=) 
        }
        lfn <- nchar(filename)
        fname <- list()
        for (f in 1:length(filename)) {
                extstart <- -1
                for (i in lfn[f] : 2) {
                        if (substr(filename[f], i, i) == .) {
                                extstart <- i
                                break 
                        }
                }
                if (extstart > 0 & (lfn[f] - extstart) < 8) {
                        fname[f] <- paste(substr(filename[f], 1, extstart-1), value, sep=)
                } else { 
                        fname[f] <- paste(filename[f], value, sep=)  
                }
        }
        return( unlist(fname) ) 
}   
.getExtension <- function(f, format) {
        if (.setfileext()) {
                def <- .defaultExtension(format)
                if (def != '') {
                        extension(f) <- def
                }
        }
        return(f)
}
.defaultExtension <- function(format=.filetype()) {
        format <- toupper(format)
        if (format == 'RASTER') { return('.grd') 
        } else if (format == 'GTIFF') { return('.tif') 
        } else if (format == 'CDF') { return('.nc')
        } else if (format == 'KML') { return('.kml')
        } else if (format == 'KMZ') { return('.kmz')
        } else if (format == 'BIG.MATRIX') { return('.big')
        } else if (format == 'BIL') { return('.bil')
        } else if (format == 'BSQ') { return('.bsq')
        } else if (format == 'BIP') { return('.bip')
        } else if (format == 'ASCII') { return('.asc')
        } else if (format == 'RST') { return('.rst') 
        } else if (format == 'ILWIS') { return('.mpr')
        } else if (format == 'SAGA') { return('.sdat')
        } else if (format == 'BMP') { return('.bmp') 
        } else if (format == 'ADRG') { return('.gen') 
        } else if (format == 'BT') { return('.bt') 
        } else if (format == 'EHdr') { return('.bil')
        } else if (format == 'ENVI') { return('.envi')
        } else if (format == 'ERS') { return('.ers') 
        } else if (format == 'GSBG') { return('.grd')
        } else if (format == 'HFA') { return( '.img') 
        } else if (format == 'IDA') { return( '.img') 
        } else if (format == 'RMF') { return('.rsw')
        } else { return('') }
}

83 extent.R

# Author: Robert J. Hijmans
# Date : January 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(extent)) {
        setGeneric(extent, function(x, ...)
                standardGeneric(extent))
}       
setMethod('extent', signature(x='Extent'), 
        function(x){ return(x) }
)
setMethod('extent', signature(x='BasicRaster'), 
        function(x, r1, r2, c1, c2){ 
                e <- x@extent
                r <- res(x)
                if (! missing(c1) )  { 
                        xn <- xFromCol(x, c1) - 0.5 * r[1]
                        if (is.na(xn)) {
                                warning('invalid first colummn')
                                xn <- e@xmin
                        }
                } else { 
                        xn <- e@xmin 
                }
                if (! missing(c2) )  { 
                        xx <- xFromCol(x, c2) + 0.5 * r[1]
                        if (is.na(xx)) {
                                warning('invalid second colummn')
                                xx <- e@xmax
                        }
                } else {
                        xx <- e@xmax 
                }
                if (! missing(r1) )  { 
                        yx <- yFromRow(x, r1) + 0.5 * r[2]
                        if (is.na(yx)) {
                                warning('invalid first row')
                                yx <- e@ymax
                        }
                } else {
                        yx <- e@ymax 
                }
                if (! missing(r2) )  {
                        yn <- yFromRow(x, r2) - 0.5 * r[2]
                        if (is.na(yn)) {
                                warning('invalid second row')                   
                                yn <- e@ymin
                        }
                } else { 
                        yn <- e@ymin 
                }
                if (xn == xx) {
                        stop('min and max x are the same')
                }
                if (yn == yx) {
                        stop('min and max y are the same')
                }
                if (xn > xx) {
                        warning('min x larger than max x')
                }
                if (yn > yx) {
                        warning('min y larger than max y')
                }

                e <- extent(sort(c(xn, xx)), sort(c(yn, yx)))
                if (validObject(e)) { 
                        return(e) 
                }
        }
)
setMethod('extent', signature(x='Spatial'), 
        function(x){ 
                bndbox <- bbox(x)
                e <- new('Extent')
                e@xmin <- bndbox[1,1]
                e@xmax <- bndbox[1,2]
                e@ymin <- bndbox[2,1]
                e@ymax <- bndbox[2,2]
                return(e) 
        }
)
setMethod('extent', signature(x='matrix'), 
        function(x){ 
                d <- dim(x)
                if (min(d) < 2) {
                        stop('matrix should have dimensions of at least 2 by 2') }              
                if (d[2] > 2) {
                        stop('matrix should not have more than 2 columns') }            
                e <- new('Extent')
                if (nrow(x) == 2) {
                # assuming a 'sp' bbox object
                        e@xmin <- min(x[1,])
                        e@xmax <- max(x[1,])
                        e@ymin <- min(x[2,])
                        e@ymax <- max(x[2,])
                } else {
                        a <- as.vector(apply(x, 2, range, na.rm=TRUE))
                        e@xmin <- a[1]
                        e@xmax <- a[2]
                        e@ymin <- a[3]
                        e@ymax <- a[4]
                }
                return(e)
        }
)

setMethod('extent', signature(x='numeric'), 
        function(x, ...){ 
                dots <- unlist(list(...))
                x <- c(x, dots)
                if (length(x) < 4) {
                        stop('insufficient number of elements (should be 4)')
                }
                if (length(x) > 4) {
                        warning('more elements than expected (should be 4)')
                }
                names(x) <- NULL
                e <- new('Extent')
                e@xmin <- x[1]
                e@xmax <- x[2]
                e@ymin <- x[3]
                e@ymax <- x[4]
                return(e)
        }       
)
# contributed by Etienne Racine
setMethod('extent', signature(x='list'),
        function(x, ...) {
                stopifnot(c(x, y) %in% names(x))
                stopifnot(lapply(x[c(x, y)], length) >= 2)
                lim <- c(range(x$x), (range(x$y)))
                return(extent(lim,...))
        }
)
setMethod('extent', signature(x='GridTopology'),
# contributed by Michael Sumner
        function(x){
                cco <- x@cellcentre.offset
                cs <- x@cellsize
                cdim <- x@cells.dim
                e <- new('Extent')
                e@xmin <- cco[1] - cs[1]/2
                e@xmax <- e@xmin + cs[1] * cdim[1]
                e@ymin <- cco[2] - cs[2]/2
                e@ymax <- e@ymin + cs[2] * cdim[2]
                return(e)
    }
)

84 extentUnion.R

# Authors: Robert J. Hijmans 
# contact: r.hijmans@gmail.com
# Date : October 2008
# Version 0.9
# Licence GPL v3

85 extractExtent.R

# Author: Robert J. Hijmans
# Date : October 2010
# Version 1.0
# Licence GPL v3
setMethod('extract', signature(x='Raster', y='Extent'), 
        function(x, y, cellnumbers=FALSE, fun=NULL, na.rm=FALSE, layer=1, nl, df=FALSE, ...) {
                e <- intersect(extent(x), y)
                e <- alignExtent(e, x)
                if (!is.null(fun)) {
                        cellnumbers <- FALSE
                } else if (cellnumbers) {
                        cell <- cellsFromExtent(x, e)
                        value <- extract(x, cell, layer=layer, nl=nl, df=df)
                        if (df) {
                                value <- data.frame(cell=cell, value)
                        } else {
                                value <- cbind(cell=cell, value)
                        }
                        return(value)
                }

                r <- res(x)
                e@xmin <- e@xmin + 0.25 * r[1]
                e@xmax <- e@xmax - 0.25 * r[1]
                e@ymin <- e@ymin + 0.25 * r[2]
                e@ymax <- e@ymax - 0.25 * r[2]

                row <- rowFromY(x, e@ymax)
                lastrow <- rowFromY(x, e@ymin)
                nrows <- lastrow-row+1
                col <- colFromX(x, e@xmin)
                lastcol <- colFromX(x, e@xmax)
                ncols <- lastcol-col+1

                v <- getValuesBlock(x, row, nrows, col, ncols)  

                if (nlayers(x) > 1) {
                        if (missing(layer)) {
                                layer <- 1
                        } else {
                                layer <- max(min(nlayers(x), layer), 1)
                        }
                        if (missing(nl)) {
                                nl <- nlayers(x) - layer + 1
                        } else {
                                nl <- max(min(nlayers(x)-layer+1, nl), 1)
                        }
                        lyrs <- layer:(layer+nl-1)
                        v <- v[ , lyrs, drop=FALSE] 
                } else {
                        lyrs <- 1
                }

                if (! is.null(fun)) {
                        if (is.matrix(v)) {
                                ln <- colnames(v)
                                v <- apply(v, 2, FUN=fun, na.rm=na.rm)
                                names(v) <- ln
                        } else {
                                v <- fun(v, na.rm=na.rm)
                        }
                }
                if (df) {
                        v <- data.frame(v)
                        if (ncol(v) == 1) {
                                v <- data.frame(factorValues(x, v, lyrs))
                        } else {
                                v <- .insertFacts(x, v, lyrs)
                        }
                }
                return(v)
        }
)

86 extractLines.R

# Author: Robert J. Hijmans
# Date : December 2009
# Version 1.0
# Licence GPL v3
setMethod('extract', signature(x='Raster', y='SpatialLines'), 
function(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...){ 
        px <- projection(x, asText=FALSE)
        comp <- compareCRS(px, projection(y), unknown=TRUE)
        if (!comp) {
                .requireRgdal()
                warning('Transforming SpatialLines to the CRS of the Raster object')
                y <- spTransform(y, px)
        }
        if (missing(layer)) {
                layer <- 1
        }
        if (missing(nl)) {
                nl <- nlayers(x)
        }       
        if (!is.null(fun)) {
                cellnumbers <- FALSE
                along <- FALSE
                if (sp) {
                        df <- TRUE
                }
        } else {
                if (sp) {
                        sp <- FALSE
                        warning('argument sp=TRUE is ignored if fun=NULL')
                }
        }

        if (along) {
                return(.extractLinesAlong(x, y, cellnumbers=cellnumbers, df=df, layer, nl, factors=factors, ...))
        }
        spbb <- bbox(y)
        rsbb <- bbox(x)
        addres <- 2 * max(res(x))
        nlns <- length( y@lines )
        res <- list()
        res[[nlns+1]] <- NA


        if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) {
                if (df) {
                        res <- matrix(ncol=1, nrow=0)
                        colnames(res) <- 'ID'
                        return(res)
                } else {
                        return(res[1:nlns])
                }
        }

        rr <- raster(x)
        cn <- names(x)
        pb <- pbCreate(nlns, label='extract', ...)

        if (.doCluster()) {
                cl <- getCluster()
                on.exit( returnCluster() )
                nodes <- min(nlns, length(cl)) 
                cat('Using cluster with', nodes, 'nodes\n')
                flush.console()
                snow::clusterExport(cl, c('rsbb', 'rr', 'addres', 'cellnumbers'), envir=environment())
                clFun <- function(i, pp) {
                        spbb <- bbox(pp)
                        if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) {
                                rc <- crop(rr, extent(pp)+addres)
                                rc <- .linesToRaster(pp, rc, silent=TRUE)
                                xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                                if (length(xy) > 0) { # always TRUE?
                                        r <- .xyValues(x, xy, layer=layer, nl=nl)
                                        if (cellnumbers) {
                                                r <- cbind(cellFromXY(rr, xy), r)
                                                colnames(r) <- c('cell', cn)
                                        }
                                } else {
                                        r <- NULL
                                }
                        }
                        r
                }

        for (ni in 1:nodes) {
                        snow::sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni)
                }

                for (i in 1:nlns) {
                        d <- snow::recvOneData(cl)
                        if (! d$value$success) {
                                stop('cluster error at polygon: ', i)
                        }
                        res[[d$value$tag]] <- d$value$value
                        ni <- ni + 1
                        if (ni <= nlns) {
                                snow::sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni)
                        }
                        pbStep(pb)
                }       


        } else {


                for (i in 1:nlns) {
                        pp <- y[i,]
                        spbb <- bbox(pp)
                        if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) {
                                rc <- crop(rr, extent(pp)+addres)
                                rc <- .linesToRaster(pp, rc, silent=TRUE)
                                xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                                if (cellnumbers) {
                                        v <- cbind(cellFromXY(rr, xy), .xyValues(x, xy, layer=layer, nl=nl))
                                        colnames(v) <- c('cell', cn)
                                        res[[i]] <- v
                                } else {
                                        res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl)
                                }
                        } 
                        pbStep(pb)
                }
        }

        res <- res[1:nlns]

        pbClose(pb)

        if (! is.null(fun)) {
                i <- sapply(res, is.null)
                if (nlayers(x) > 1) {
                        j <- matrix(ncol=nlayers(x), nrow=length(res))
                        j[!i] <- t(sapply(res[!i], function(x) apply(x, 2, fun, na.rm=na.rm)))
                        colnames(j) <- names(x)
                } else {
                        j <- vector(length=length(i))
                        j[i] <- NA
                        j[!i] <- sapply(res[!i], fun, na.rm=na.rm)
                }
                res <- j
        }

        if (df) {
                if (!is.list(res)) {
                        res <- data.frame(ID=1:NROW(res), res)
                } else {
                        res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) )
                }               
                lyrs <- layer:(layer+nl-1)
                colnames(res) <- c('ID', names(x)[lyrs])

                if (any(is.factor(x)) & factors) {
                        v <- res[, -1, drop=FALSE]
                        if (ncol(v) == 1) {
                                v <- data.frame(factorValues(x, v[,1], layer))
                        } else {
                                v <- .insertFacts(x, v, lyrs)
                        }
                        res <- data.frame(res[,1,drop=FALSE], v)
                }
        }

        if (sp) {
                if (nrow(res) != nlns) {
                        warning('sp=TRUE is ignored because fun does not summarize the values of each line to a single number')
                        return(res)
                }

                if (! .hasSlot(y, 'data') ) {
                        y <- SpatialLinesDataFrame(y,  res[, -1, drop=FALSE])
                } else {
                        y@data <- cbind(y@data,  res[, -1, drop=FALSE])
                }
                return(y)
        }


        res
}
)
.extractLinesAlong <- function(x, y, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, ...){ 
        spbb <- bbox(y)
        rsbb <- bbox(x)
        addres <- 2 * max(res(x))
        nlns <- length( y@lines )
        res <- list()
        res[[nlns+1]] <- NA
        if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) {
                if (df) {
                        res <- matrix(ncol=1, nrow=0)
                        colnames(res) <- 'ID'
                        return(res)
                } else {
                        return(res[1:nlns])
                }
        }

        rr <- raster(x)
        cn <- names(x)

        pb <- pbCreate(nlns, label='extract', ...)

        y <- as.data.frame(y, xy=TRUE)  
        for (i in 1:nlns) {
                yp <- y[y$object == i, ]
                nparts <- max(yp$part)
                vv <- NULL
                for (j in 1:nparts) {
                        pp <- yp[yp$part==j, c('x', 'y'), ]
                        for (k in 1:(nrow(pp)-1)) {
                                ppp <- pp[k:(k+1), ]
                                spbb <- bbox(as.matrix(ppp))
                                if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) {
                                        lns <- SpatialLines(list(Lines(list(Line(ppp)), 1)))
                                        rc <- crop(rr, extent(lns) + addres)
                                        rc <- .linesToRaster(lns, rc, silent=TRUE)
                                        xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                                        v <- cbind(row=rowFromY(rr, xy[,2]), col=colFromX(rr, xy[,1]), .xyValues(x, xy, layer=layer, nl=nl))
                                        #up or down?

                                        updown <- c(1,-1)[(ppp[1,2] < ppp[2,2]) + 1]
                                        rightleft <- c(-1,1)[(ppp[1,1] < ppp[2,1]) + 1]
                                        v <- v[order(updown*v[,1], rightleft*v[,2]), ]
                                        #up <- ppp[1,2] < ppp[2,2]
                                        #right <- ppp[1,1] < ppp[2,1]                                   
#                                       if (up) {
#                                               if (right) {
#                                                       v <- v[order(-v[,1], v[,2]), ]
#                                               } else {
#                                                       v <- v[order(-v[,1], -v[,2]), ]
#                                               }

#                                       } else {
#                                               if (!right) {
#                                                       v <- v[order(v[,1], -v[,2]), ]
#                                               }
#                                       }
                                        vv <- rbind(vv, v)
                                }
                        } 
                        if (cellnumbers) {
                                vv <- cbind(cellFromRowCol(rr, vv[,1], vv[,2]), vv[,-c(1:2)])
                                colnames(vv) <- c('cell', names(x))
                        } else {
                                vv <- vv[,-c(1:2)]
                                if (NCOL(vv) > 1) {
                                        colnames(vv) <- names(x)
                                }
                        }
                        res[[i]] <- vv
                        pbStep(pb)
                }
        }

        res <- res[1:nlns]
        pbClose(pb)


        if (df) {
                res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) )
                lyrs <- layer:(layer+nl-1)
                colnames(res) <- c('ID', names(x)[lyrs])

                if (any(is.factor(x)) & factors) {
                        v <- res[, -1, drop=FALSE]
                        if (ncol(v) == 1) {
                                v <- data.frame(factorValues(x, v[,1], layer))
                        } else {
                                v <- .insertFacts(x, v, lyrs)
                        }
                        res <- data.frame(res[,1,drop=FALSE], v)
                }
        }
        res
}

87 extractPoints.R

# Author: Robert J. Hijmans
# Date : November 2008
# Version 1.0
# Licence GPL v3
setMethod('extract', signature(x='Raster', y='matrix'), 
function(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...){ 
        .xyValues(x, y, method=method, buffer=buffer, small=small, cellnumbers=cellnumbers, fun=fun, na.rm=na.rm, layer=layer, nl=nl, df=df, factors=factors, ...)
})
setMethod('extract', signature(x='Raster', y='data.frame'), 
function(x, y, ...){ 
        return( .xyValues(x, as.matrix(y), ...))
})
setMethod('extract', signature(x='SpatialPolygons', y='SpatialPoints'), 
function(x, y, ...){ 

        stopifnot(require(rgeos))

        if (! identical(proj4string(x), proj4string(y)) ) {
                warning('non identical CRS')
                y@proj4string <- x@proj4string
        }
    i <- rgeos::gIntersects(y, x, byid=TRUE)

        j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i)))
        j <- j[j[,3] == 1, -3]
        colnames(j) <- c('point.ID', 'poly.ID')
        if (.hasSlot(x, 'data')) {
                r <- data.frame(j, x@data[j[,2], ,drop=FALSE], row.names=NULL)
        } else {
                r <- data.frame(j, row.names=NULL)
        }
        q <- data.frame(point.ID = 1:length(y))
        merge(q, r, by='point.ID', all=TRUE)
})
setMethod('extract', signature(x='Raster', y='SpatialPoints'), 
function(x, y, ..., df=FALSE, sp=FALSE){ 
        px <- projection(x, asText=FALSE)
        comp <- compareCRS(px, projection(y), unknown=TRUE)
        if (!comp) {
                if (!.requireRgdal()) {
                        warning('CRS of SpatialPoints and rater do not match')
                } else {
                        warning('Transforming SpatialPoints to the CRS of the Raster')
                        y <- spTransform(y, px)
                }
        }
        if (sp) {
                v <- .xyValues(x, coordinates(y), ..., df=TRUE)
                if (!.hasSlot(y, 'data')) {
                        y <- SpatialPointsDataFrame(y,  v[, -1, drop=FALSE])
                } else {
                        y@data <- cbind(y@data, v[, -1, drop=FALSE])
                }
                return(y)
        } else {
                .xyValues(x, coordinates(y), ..., df=df)
        }
})

.xyValues <- function(object, xy, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, sp=FALSE, ...) { 
        nlyrs <- nlayers(object)
        if (nlyrs > 1) {
                if (missing(layer)) { layer <- 1 } 
                if (missing(nl)) { nl <- nlyrs } 
                layer <- min(max(1, round(layer)), nlyrs)
                nl <- min(max(1, round(nl)), nlyrs-layer+1)
        } else {
                layer <- 1
                nl <- 1
        }

        if (dim(xy)[2] != 2) {
                stop('xy should have 2 columns only.\nFound these dimensions: ', paste(dim(xy), collapse=', ') )
        }

        if (! is.null(buffer)) {
                if (method != 'simple') { 
                        warning('method argument is ignored when a buffer is used') 
                }
                res <- .xyvBuf(object, xy, buffer, fun, na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers, small=small)                

        } else if (method == 'bilinear') {
                res <- .bilinearValue(object, xy, layer=layer, n=nl) 
                if (cellnumbers) {
                        warning('cellnumbers' does not apply for bilinear values)
                }
        } else if (method=='simple') {
                cells <- cellFromXY(object, xy)
                res <- .cellValues(object, cells, layer=layer, nl=nl) 
                if (cellnumbers) {                      
                        res <- cbind(cells, res)
                        if (ncol(res) == 2) {
                                colnames(res)[2] <- names(object)[layer]
                        } 
                }

        } else {
                stop('invalid method argument. Should be simple or bilinear.')
        }

        if (df) {
                if (is.list(res)) {
                        res <- lapply(1:length(res), function(x) if (length(res[[x]]) > 0) cbind(ID=x, res[[x]]))
                        res <- do.call(rbind, res)
                        rownames(res) <- NULL
                } else {
                        res <- data.frame(cbind(ID=1:NROW(res), res))
                }
                lyrs <- layer:(layer-1+nl)
                colnames(res) <- c('ID', names(object)[lyrs])
                if (any(is.factor(object)) & factors) {
                        v <- res[, -1, drop=FALSE]
                        if (ncol(v) == 1) {
                                v <- data.frame(factorValues(object, v[,1], layer))
                        } else {
                                v <- .insertFacts(object, v, lyrs)
                        }
                        res <- data.frame(res[,1,drop=FALSE], v)
                }
        }

        res
}

88 extractPolygons.R

# Author: Robert J. Hijmans
# Date : December 2009
# Version 0.9
# Licence GPL v3
setMethod('extract', signature(x='Raster', y='SpatialPolygons'), 
function(x, y, fun=NULL, na.rm=FALSE, weights=FALSE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...){ 
        px <- projection(x, asText=FALSE)
        comp <- compareCRS(px, projection(y), unknown=TRUE)
        if (!comp) {
                .requireRgdal()
                warning('Transforming SpatialPolygons to the CRS of the Raster')
                y <- spTransform(y, px)
        }

        spbb <- bbox(y)
        rsbb <- bbox(x)
        addres <- max(res(x))
        npol <- length(y@polygons)
        res <- list()
        res[[npol+1]] <- NA

        if (!is.null(fun)) {
                cellnumbers <- FALSE
            if (weights) {
                        if (!is.null(fun)) {
                                test <- try(slot(fun, 'generic') == 'mean', silent=TRUE)
                                if (!isTRUE(test)) {
                                        warning('fun was changed to mean; other functions cannot be used when weights=TRUE' )
                                }
                        }
                        fun <- function(x, ...) {
                                # some complexity here because different layers could 
                                # have different NA cells
                                if ( is.null(x) ) {
                                        return(rep(NA, nl))
                                }
                                w <- x[,nl+1]
                                x <- x[,-(nl+1), drop=FALSE]
                                x <- x * w
                                w <- matrix(rep(w, nl), ncol=nl)
                                w[is.na(x)] <- NA
                                w <- colSums(w, na.rm=TRUE)
                                x <- apply(x, 1, function(X) { X / w } )
                                if (!is.null(dim(x))) {
                                        rowSums(x, na.rm=na.rm)
                                } else {
                                        sum(x, na.rm=na.rm)
                                }
                        }
                }

                if (sp) {
                        df <- TRUE
                }

                doFun <- TRUE

        } else {
                if (sp) {
                        sp <- FALSE
                        df <- FALSE
                        warning('argument sp=TRUE is ignored if fun=NULL')
                } else if (df) {
                        df <- FALSE
                        warning('argument df=TRUE is ignored if fun=NULL')
                }

                doFun <- FALSE
        }

        if (missing(layer)) {
                layer <- 1
        } else {
                layer <- max(min(nlayers(x), layer), 1)
        }
        if (missing(nl)) {
                nl <- nlayers(x) - layer + 1
        } else {
                nl <- max(min(nlayers(x)-layer+1, nl), 1)
        }


        if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) {
                if (df) {
                        res <- data.frame(matrix(ncol=1, nrow=0))
                        colnames(res) <- 'ID'
                        return(res)
                }
                return(res[1:npol])
        }


        rr <- raster(x)

        pb <- pbCreate(npol, label='extract', ...)

        if (.doCluster()) {
                cl <- getCluster()
                on.exit( returnCluster() )
                nodes <- min(npol, length(cl)) 
                cat('Using cluster with', nodes, 'nodes\n')
                flush.console()

                snow::clusterExport(cl, c('rsbb', 'rr', 'weights', 'addres', 'cellnumbers', 'small'), envir=environment())
                clFun <- function(i, pp) {
                        spbb <- bbox(pp)

                        if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) {
                                # do nothing; res[[i]] <- NULL
                        } else {
                                rc <- crop(rr, extent(pp)+addres)
                                if (weights) {
                                        rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE)
                                        rc[rc==0] <- NA
                                        xy <- rasterToPoints(rc)
                                        weight <- xy[,3] / sum(xy[,3])
                                        xy <- xy[, -3, drop=FALSE]
                                } else {
                                        rc <- .polygonsToRaster(pp, rc, silent=TRUE)
                                        xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                                }

                                if (length(xy) > 0) { # catch very small polygons
                                        r <- .xyValues(x, xy, layer=layer, nl=nl)
                                        if (weights) {
                                                if (cellnumbers) {
                                                        cell <- cellFromXY(x, xy)
                                                        r <- cbind(cell, r, weight)
                                                } else {                                
                                                        r <- cbind(r, weight)
                                                }
                                        } else if (cellnumbers) {
                                                cell <- cellFromXY(x, xy)
                                                r <- cbind(cell, r)                                             
                                        } 
                                } else {
                                        if (small) {
                                                ppp <- pp@polygons[[1]]@Polygons
                                                ishole <- sapply(ppp, function(z)z@hole)
                                                xy <- lapply(ppp, function(z)z@coords)
                                                xy <- xy[!ishole]
                                                if (length(xy) > 0) {
                                                        cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z))))
                                                        value <- .cellValues(x, cell, layer=layer, nl=nl)
                                                        if (weights) {
                                                                weight=rep(1/NROW(value), NROW(value))
                                                                if (cellnumbers) {
                                                                        r <- cbind(cell, value, weight)
                                                                } else {
                                                                        r <- cbind(value, weight)                                                               
                                                                }
                                                        } else if (cellnumbers) {
                                                                r <- cbind(cell, value)                                 
                                                        } else {
                                                                r <- value
                                                        }
                                                } else {
                                                        r <- NULL
                                                }
                                        } else {
                                                r <- NULL
                                        }
                                }
                        }
                        r
                }

        for (ni in 1:nodes) {
                        snow::sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni)
                }

                for (i in 1:npol) {
                        d <- snow::recvOneData(cl)
                        if (! d$value$success) {
                                stop('cluster error at polygon: ', i)
                        }
                        if (doFun) {
                                if (!is.null(d$value$value)) {
                                        if (nl > 1 & !weights) {
                                                res[[i]] <- apply(d$value$value, 2, fun, na.rm=na.rm)                                                   
                                        } else { 
                                                res[[d$value$tag]] <- fun(d$value$value)
                                        }
                                }
                        } else {
                                res[[d$value$tag]] <- d$value$value
                        }
                        ni <- ni + 1
                        if (ni <= npol) {
                                snow::sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni)
                        }
                        pbStep(pb, i)
                }

        } else {
                for (i in 1:npol) {
                        pp <- y[i,]
                        spbb <- bbox(pp)

                        if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) {
                                # do nothing; res[[i]] <- NULL
                        } else {
                                rc <- crop(rr, extent(pp)+addres)
                                if (weights) {
                                        rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE)
                                        rc[rc==0] <- NA
                                        xy <- rasterToPoints(rc)
                                        weight <- xy[,3] / sum(xy[,3])
                                        xy <- xy[,-3,drop=FALSE]
                                } else {
                                        rc <- .polygonsToRaster(pp, rc, silent=TRUE)
                                        xy <- rasterToPoints(rc)[,-3,drop=FALSE]
                                }

                                if (length(xy) > 0)  {  # catch holes or very small polygons
                                        if (weights) {
                                                value <- .xyValues(x, xy, layer=layer, nl=nl)
                                                if (cellnumbers) {
                                                        cell <- cellFromXY(x, xy)
                                                        res[[i]] <- cbind(cell, value, weight)
                                                } else {                                
                                                        res[[i]] <- cbind(value, weight)
                                                }
                                        } else if (cellnumbers) {
                                                value <- .xyValues(x, xy, layer=layer, nl=nl)
                                                cell <- cellFromXY(x, xy)
                                                res[[i]] <- cbind(cell, value)          
                                        } else {
                                                res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl)
                                        }
                                } else if (small) {
                                        ppp <- pp@polygons[[1]]@Polygons
                                        ishole <- sapply(ppp, function(z)z@hole)
                                        xy <- lapply(ppp, function(z)z@coords)
                                        xy <- xy[!ishole]
                                        if (length(xy) > 0) {
                                                cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z))))
                                                value <- .cellValues(x, cell, layer=layer, nl=nl)
                                                if (weights) {
                                                        weight=rep(1/NROW(value), NROW(value))
                                                        if (cellnumbers) {
                                                                res[[i]] <- cbind(cell, value, weight)
                                                        } else {
                                                                res[[i]] <- cbind(value, weight)
                                                        }
                                                } else if (cellnumbers) {
                                                        res[[i]] <- cbind(cell, value)                                  
                                                } else {
                                                        res[[i]] <- value
                                                }
                                        } # else do nothing; res[[i]] <- NULL
                                } 
                                if (doFun) {
                                        if (!is.null(res[[i]])) {
                                                if (nl > 1 & !weights) {
                                                        res[[i]] <- apply(res[[i]], 2, fun, na.rm=na.rm)                                                        
                                                } else {
                                                        res[[i]] <- fun(res[[i]])
                                                }
                                        }
                                }       
                        }
                        pbStep(pb)
                }
        }
        res <- res[1:npol]
        pbClose(pb)

        if (! is.null(fun)) {
                # try to simplify
                i <- sapply(res, length)
                if (length(unique(i[i != 0])) == 1) {
                        if (any(i == 0)) {
                                lng <- length(res)
                                v <- do.call(rbind, res)
                                res <- matrix(NA, nrow=lng, ncol=ncol(v))
                                res[which(i > 0), ] <- v
                        } else {
                                res <- do.call(rbind, res)
                        }
                } else {
                        if (sp) {
                                warning('cannot return a sp object because the data length varies between polygons')
                                sp <- FALSE
                                df <- FALSE
                        } else if (df) {
                                warning('cannot return a data.frame because the data length varies between polygons')
                                df <- FALSE
                        }
                }
        }

        if (df) {
                if (!is.list(res)) {
                        res <- data.frame(ID=1:NROW(res), res)
                } else {
                        res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) )
                }               
                lyrs <- layer:(layer+nl-1)
                if (cellnumbers) {
                        nms <- c('ID', 'cell', names(x)[lyrs])
                } else {
                        nms <- c('ID', names(x)[lyrs])
                }
                if (weights & is.null(fun)) {
                        nms <- c(nms, 'weight')
                }
                colnames(res) <- nms

                if (any(is.factor(x)) & factors) {
                        i <- ifelse(cellnumbers, 1:2, 1)
                        v <- res[, -i, drop=FALSE]
                        if (ncol(v) == 1) {
                                v <- data.frame(factorValues(x, v[,1], layer))
                        } else {
                                v <- .insertFacts(x, v, lyrs)
                        }
                        res <- data.frame(res[,i,drop=FALSE], v)
                }
        }

        if (sp) {
                if (nrow(res) != npol) {
                        warning('sp=TRUE is ignored because fun does not summarize the values of each polygon to a single number')
                        return(res)
                }

                if (! .hasSlot(y, 'data') ) {
                        y <- SpatialPolygonsDataFrame(y, res[, -1, drop=FALSE])
                } else {
                        y@data <- cbind(y@data, res[, -1, drop=FALSE])
                }
                return(y)
        }
        res
}
)

89 extract.R

# Author: Robert J. Hijmans
# Date : October 2010
# Version 1.0
# Licence GPL v3
if (!isGeneric(extract)) {
        setGeneric(extract, function(x, y, ...)
                standardGeneric(extract))
}       
setMethod('extract', signature(x='Raster', y='vector'), 
function(x, y, ...){ 
        y <- round(y)
        return( .cellValues(x, y, ...) )
})

90 factor.R

# Author: Robert J. Hijmans
# Date : February 2010 / June 2012
# Version 1.0
# Licence GPL v3
factorValues <- function(x, v, layer=1, att=NULL, append.names=FALSE) {
        stopifnot(is.factor(x)[layer])
        rat <- levels(x)[[layer]]
        if (!is.data.frame(rat)) {
                rat <- rat[[1]]
        }
#       if (colnames(rat)[2]=='WEIGHT') {
#               i <- which(match(rat$ID, round(v))==1)
#       } else {
                i <- match(round(v), rat$ID)
#       }
        r <- rat[i, -1, drop=FALSE]
        rownames(r) <- NULL
        if (!is.null(att)) {
                if (is.character(att)) {
                        att <- na.omit(match(att, colnames(r)))
                        if (length(att) == 0) {
                                warning(att does not includes valid names)
                        } else {
                                r <- r[, att, drop=FALSE]
                        }
                } else {
                        r <- r[, att, drop=FALSE]
                }
        }
        if (append.names) {
                colnames(r) <- paste(names(x)[layer], colnames(r), sep=_)
        }
        r
}
.insertFacts <- function(x, v, lyrs) {
        facts <- is.factor(x)[lyrs]
        if (!any(facts)) {
                return(v)
        }
        i <- which(facts)
        v <- sapply(1:length(facts), 
                function(i) {
                        if (facts[i]) {
                                data.frame(factorValues(x, v[, i], i, append.names=TRUE))
                        } else {
                                v[, i, drop=FALSE]
                        }
                } )
        do.call(data.frame, v)
}

if (!isGeneric(is.factor)) {
        setGeneric(is.factor, function(x)
                standardGeneric(is.factor))
}       
setMethod('is.factor', signature(x='Raster'), 
        function(x) {
                f <- x@data@isfactor
                nl <- nlayers(x)
                if (length(f) < nl) {
                        f <- c(f, rep(FALSE, nl))[1:nl]
                }
                f
        }
)
setMethod('is.factor', signature(x='RasterStack'), 
        function(x) {
                sapply(x@layers, function(x) x@data@isfactor)
        }
)
if (!isGeneric(levels)) {
        setGeneric(levels, function(x)
                standardGeneric(levels))
}       
setMethod('levels', signature(x='Raster'), 
        function(x) {
                f <- is.factor(x)
                if (any(f)) {
                        if (inherits(x, 'RasterStack')) {
                                return( sapply(x@layers, function(i) i@data@attributes)  )
                        } else {
                                return(x@data@attributes)
                        }
                } else {
                        return(NULL)
                }
        }
)
.checkLevels <- function(old, newv) {
        if (! is.data.frame(newv)) { 
                stop('new raster attributes (factor values) should be in a data.frame (inside a list)')
        }
        if (! ncol(newv) > 0) {
                stop('the number of columns in the raster attributes (factors) data.frame should be > 0')
        }
        if (! colnames(newv)[1] == c('ID')) {
                stop('the first column name of the raster attributes (factors) data.frame should be ID')
        }

        if (!is.null(old)) {
#               if (colnames(newv)[2] == 'WEIGHT') {
#                       if (nrow(newv) < nrow(old)) {
#                               warning('the number of rows in the raster attributes (factors) data.frame is lower than expected (values missing?)')
#                       }
#                       if (! all(unique(sort(newv[,1])) == sort(unique(old[,1])))) {
#                               warning('the values in the ID column in the raster attributes (factors) data.frame have changed')
#                       }

#               } else {

                        if (! nrow(newv) == nrow(old)) {
                                warning('the number of rows in the raster attributes (factors) data.frame is unexpected')
                        }
                        if (! all(sort(newv[,1]) == sort(old[,1]))) {
                                warning('the values in the ID column in the raster attributes (factors) data.frame have changed')
                        }
#               }
        }
        newv[, 1] <- as.integer(newv[, 1])
#       if (colnames(newv)[2] == 'WEIGHT') {
#               newv[, 2] <- as.numeric(newv[, 2])
#       }
        newv
}
setMethod('levels<-', signature(x='Raster'), 
        function(x, value) {

                isfact <- is.factor(x)
                if (inherits(x, 'RasterLayer')) {
                        if (!is.data.frame(value)) {
                                if (is.list(value)) {
                                        value <- value[[1]]
                                }
                        }
                        value <- .checkLevels(levels(x)[[1]], value)
                        x@data@attributes <- list(value)
                        x@data@isfactor <- TRUE
                        return(x)
                } 

                i <- ! sapply(value, is.null)
                if ( any(i) ) {
                        stopifnot (length(value) == nlayers(x))
                        levs <- levels(x)
                        for (j in which(i)) {
                                value[[j]] <- .checkLevels(levs[[j]], value[[j]])
                        }
                        x@data@attributes <- value
                        x@data@isfactor <- i
                } else {
                        x@data@attributes <- list()             
                }
                x@data@isfactor <- i
                return(x)               
        }
)
if (!isGeneric(as.factor)) {
        setGeneric(as.factor, function(x)
                standardGeneric(as.factor))
}
setMethod('as.factor', signature(x='RasterLayer'), 
        function(x) {
                ratify(x)
        }
)
if (!isGeneric(asFactor)) {
        setGeneric(asFactor, function(x, ...)
                standardGeneric(asFactor))
}
setMethod('asFactor', signature(x='RasterLayer'), 
        function(x, value=NULL, ...) {
                #warning(please use as.factor)
                x@data@isfactor <- TRUE
                if (is.null(value) ) {
                        #x <- round(x) #this makes slot isfactor FALSE again
                        x@data@attributes <- list(data.frame(VALUE=unique(x)))
                } else {
                        x@data@attributes <- value
                }       
                return(x)
        }
)

91 filler.R

.filler <- function(x, y, maxv=12, circular=FALSE) {
# should rewrite this using apply (or C)
        fill <- function(x, y) {
                r <- matrix(NA, nrow=length(x), ncol=maxv)
                if (circular) {
                        for (i in 1:nrow(r)) {
                                if (!is.na(y[i])) {
                                        if (x[i] < y[i]) {
                                                r[i, x[i]:y[i]] <- 1
                                        } else {
                                                r[i, c(x[i]:maxv, 1:y[i])] <- 1 
                                        }
                                }
                        }
                        r
                } else {
                        for (i in 1:nrow(r)) {
                                if (!is.na(y[i])) {
                                        r[i, x[i]:y[i]] <- 1
                                }
                        }
                        r
                }
        }
        x <- overlay(x, y, fun=fill)
        names(x) = paste('v', 1:maxv, sep='')
        x
}

92 fixDBFnames.R

.fixDBFNames <- function(x, verbose=TRUE) {
    n <- gsub('^[[:space:]]+', '',  gsub('[[:space:]]+$', '', x) )
    nn <- n
    n <- gsub('[^[:alnum:]]', '_', n)
    n[nchar(n) > 10] <- gsub('_', '', n[nchar(n) > 10])
    n[n==''] <- 'field'
    n <- gsub('^[^[:alpha:]]', 'X', n)
    n <- substr(n, 1, 10)
       # duplicate names
    nn  <- as.matrix(table(n))
    i <- which(nn > 1)
    if (! is.null(i)) {
        names <- rownames(nn)[i]
        n[n %in% names] <- substr(n[n %in% names], 1, 9)
        n <- make.unique(n, sep = )
    }
        if (verbose) {
                i <- x == n
                if (! all(i)) {
                        x <- rbind(x, n)
                        colnames(x) <- paste('col_', 1:ncol(x), sep=)
                        x <- x[, !i, drop=FALSE]
                        rownames(x) = c('original name', 'adjusted name')
                        print(x)
                }
    }
    return(n)
}

93 flip.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(flip)) {
        setGeneric(flip, function(x, direction, ...)
                standardGeneric(flip))
}
setMethod('flip', signature(x='RasterLayer', direction='ANY'), 
        function(x, direction='y', filename='', ...)  {

                filename <- trim(filename)
                outRaster <- raster(x)
                if (direction[1] == 1) { 
                        direction <- 'x'
                } else if (direction[1] == 2) { 
                        direction <- 'y' 
                }
                if (!(direction %in% c('y', 'x'))) {
                        stop('direction should be y or x')
                }

                if (!canProcessInMemory(outRaster, 2) && filename == '') {
                        filename <- rasterTmpFile()
                        inmemory = FALSE
                } else {
                        inmemory = TRUE
                }

                if ( inmemory ) {
                        x <- getValues(x, format='matrix')
                        if (direction == 'y') {
                                x <- x[nrow(x):1,]
                        } else {
                                x <- x[,ncol(x):1]
                        }
                        outRaster <- setValues(outRaster, as.vector(t(x)))
                        if (filename != '') {
                                outRaster = writeRaster(outRaster, filename=filename, ...)
                        }

                } else {
                        tr <- blockSize(outRaster)
                        pb <- pbCreate(tr$n, label='flip', ...)
                        outRaster <- writeStart(outRaster, filename=filename, datatype=dataType(x), ... )
                        if (direction == 'y') {
                                nr <- nrow(outRaster)
                                for (i in 1:tr$n) {
                                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                        v <- matrix(v, ncol=ncol(x), byrow=TRUE)
                                        v <- as.vector(t(v[nrow(v):1, ]))
                                        rownr <- nr - tr$row[i] - tr$nrows[i] + 2
                                        outRaster <- writeValues(outRaster, v, rownr)
                                        pbStep(pb, i) 
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                        v <- matrix(v, ncol=ncol(x), byrow=TRUE)
                                        v <- as.vector(t(v[, ncol(v):1]))
                                        outRaster <- writeValues(outRaster, v, tr$row[i])
                                        pbStep(pb, i) 
                                }
                        }
                        outRaster <- writeStop(outRaster)
                        pbClose(pb)
                }
                return(outRaster)
        }
)
setMethod('flip', signature(x='RasterStackBrick', direction='ANY'), 
        function(x, direction='y', filename='', ...)  {

                filename <- trim(filename)
                outRaster <- brick(x, values=FALSE)
                if (direction[1] == 1) { 
                        direction <- 'x'
                } else if (direction[1] == 2) { 
                        direction <- 'y' 
                }
                if (!(direction %in% c('y', 'x'))) {
                        stop('directions should be y or x')
                }

                if (!canProcessInMemory(outRaster, 2) && filename == '') {
                        filename <- rasterTmpFile()
                        inmemory = FALSE
                } else {
                        inmemory = TRUE
                }
                nc <- outRaster@ncols

                if ( inmemory ) {
                        x <- getValues(x)
                        for (i in 1:NCOL(x)) {
                                v <- matrix(x[,i], ncol=nc, byrow=TRUE)
                                if (direction == 'y') {
                                        v <- v[nrow(v):1,]
                                } else {
                                        v <- v[,ncol(v):1]
                                }
                                x[,i] <- as.vector(t(v))
                        }
                        outRaster <- setValues(outRaster, x)
                        if (filename != '') {
                                outRaster = writeRaster(outRaster, filename=filename, ...)
                        }

                } else {
                        tr <- blockSize(outRaster)
                        pb <- pbCreate(tr$n, label='flip', ...)
                        if (inherits(x, 'RasterStack')) { 
                                dtype <- 'FLT4S'
                        } else {
                                dtype <- dataType(x)
                        }
                        outRaster <- writeStart(outRaster, filename=filename, datatype=dtype, ... )
                        if (direction == 'y') {
                                trinv <- tr
                                trinv$row <- rev(trinv$row)
                                trinv$nrows <- rev(trinv$nrows)
                                trinv$newrows <- cumsum(c(1,trinv$nrows))[1:length(trinv$nrows)]
                                for (i in 1:tr$n) {
                                        vv <- getValues(x, row=trinv$row[i], nrows=trinv$nrows[i])
                                        for (j in 1:NCOL(vv)) {
                                                v <- matrix(vv[,j], nrow=nc)
                                                vv[,j] <- as.vector(v[, ncol(v):1])
                                        }
                                        outRaster <- writeValues(outRaster, vv, trinv$newrows[i])
                                        pbStep(pb, i) 
                                }

                        } else {

                                for (i in 1:tr$n) {
                                        vv = getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                        for (j in 1:NCOL(vv)) {
                                                v <- matrix(vv[,j], nrow=nc)
                                                vv[,j] <- as.vector(v[nrow(v):1, ])
                                        }
                                        outRaster <- writeValues(outRaster, vv, tr$row[i])
                                        pbStep(pb, i) 
                                }  
                        }

                        outRaster <- writeStop(outRaster)
                        pbClose(pb)
                }
                return(outRaster)
        }
)

94 flowpath.R

# drain.R
# This script calculates the drainage of a point on a DEM - in R!
# written by A. Shortridge, 10/2013
# changes by Robert Hijmans
flowPath <- function(x, p, ...) {
        r <- raster(x)
        if (length(p) > 1) {
                p <- cellFromXY(r, p[1:2])
        }
        cell <- p
        row <- rowFromCell(r, cell)
        col <- colFromCell(r, cell)             
        nr <- nrow(r)
        nc <- ncol(r)
        path <- NULL
    while (!is.na(x[cell])) {  
        path <- c(path, cell)
        fd <- x[cell]
        row <- if(fd %in% c(32, 64, 128)) row - 1 else
                if(fd %in% c(8, 4, 2)) row + 1 else row
        col <- if(fd %in% c(32, 16, 8)) col - 1 else 
                if(fd %in% c(128, 1, 2)) col + 1 else col
                cell <- cellFromRowCol(r, row, col)
       # Don't drain off the raster or drain NA cells on x!
        if (is.na(x[cell])) break 
        # avoid cell i draining to j and j draining to i traps
        if (cell %in% path) break  
    }
    return(path)
}
.flowPath1 <- function(x, p) {
    # This function creates a raster with 1s representing a path from
    # the start cell to the end of the flowpath. x is a flow raster
    # created with the terrain() function in raster. Returns a raster
    # where 1 represents a part of this path and 0 is off-path.

        out <- raster(x)
        if (length(p) > 1) {
                p <- cellFromXY(out, p[1:2])
        }
        row <- rowFromCell(out, p)
        col <- colFromCell(out, p)

    out[row, col] <- 1
    while (!is.na(x[row, col])) {  # not in a pit
        out[row, col] <- 1
        fdval <- x[row, col]

        col <- if(fdval %in% c(32, 16, 8)) col - 1 else 
                if(fdval %in% c(128, 1, 2)) col + 1 else col

        row <- if(fdval %in% c(32, 64, 128)) row - 1 else
                if(fdval %in% c(8, 4, 2)) row + 1 else row

        # Don't drain off the raster!
        if (row < 1 || row > dim(x)[1] || col < 1 || col > dim(x)[2]) break
        # Don't drain NA cells on x!
        if (is.na(x[row, col])) break 
        # avoid cell i draining to j and j draining to i traps
        if (!is.na(out[row, col])) break  
    }
    return(out)
}

95 focalFun.R

# Author: Robert J. Hijmans
# Date : March 2014
# Version 1.0
# Licence GPL v3
#if ( !isGeneric(focalFun) ) {
#       setGeneric(focalFun, function(x, ...)
#               standardGeneric(focalFun))
#}
#setMethod('focalFun', signature(x='Raster'), 
.focalFun <- function(x, fun, ngb=5, filename='', ...) {

        out <- raster(x)

        if (.doCluster()) {
                cl <- getCluster()
                on.exit( returnCluster() )

                if (canProcessInMemory(x)) {
                        v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE)
                        v <- snow::parApply(cl, v, 1, fun)
                        out <- setValues(out, v)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='focalFun', ...)
                        out <- writeStart(out, filename=filename, ...)
                        for (i in 1:tr$n) {
                                v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE)
                                v <- snow::parApply(cl, v, 1, fun)
                                out <- writeValues(out, v, tr$row[i])
                        }
                }
                return(writeStop(out))
        } else {

                if (canProcessInMemory(x)) {
                        v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE)
                        v <- apply(v, 1, fun)
                        out <- setValues(out, v)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)

                } else {
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='focalFun', ...)
                        out <- writeStart(out, filename=filename, ...)
                        for (i in 1:tr$n) {
                                v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE)
                                v <- apply(v, 1, fun)
                                out <- writeValues(out, v, tr$row[i])
                        }
                }
                return(writeStop(out))
        }
}       

#)

96 focal.R

# Author: Robert J. Hijmans
# Date :  October 2011
# Version 1.0
# Licence GPL v3
.checkngb <- function(ngb, mustBeOdd=FALSE) {
        ngb <- as.integer(round(ngb))
        if (length(ngb) == 1) {
                ngb <- c(ngb, ngb)
        } else if (length(ngb) > 2) {
                stop('ngb should be a single value or two values')
        }
        if (min(ngb) < 1) { stop(ngb should be larger than 1) } 
        if (mustBeOdd) {
                if (any(ngb %% 2 == 0)) {
                        stop('neighborhood size must be an odd number')
                }
        }
        return(ngb)
}
.wwarn <- function() {
        if (! isTRUE(options('rasterFocalWarningGiven'))) {
                warning('the computation of the weights matrix has changed in version 2.1-35. The sum of weights is now 1')
                options(rasterFocalWarningGiven=TRUE)
        }
}
.getW <- function(w) {
        if (length(w) == 1) {
                w <- round(w)
                stopifnot(w > 0)
                w <- matrix(1, ncol=w, nrow=w)
                w <- w / sum(w)
                .wwarn()
        } else if (length(w) == 2) {
                w <- round(w)
                w <- matrix(1, ncol=w[1], nrow=w[2])
                w <- w / sum(w)
                .wwarn()
        } 
        if (! is.matrix(w) ) {
                stop('w should be a single number, two numbers, or a matrix')
        } 
        return(w)
}
if (!isGeneric(focal)) {
        setGeneric(focal, function(x, ...)
                standardGeneric(focal))
}       
setMethod('focal', signature(x='RasterLayer'), 
function(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) {
        stopifnot(hasValues(x))

        # mistakes because of differences with old focal and old focalFilter
        dots <- list(...)
        if (!is.null(dots$filter)) {
                warning('argument filter is ignored!')
        }
        if (!is.null(dots$ngb)) {
                warning('argument ngb is ignored!')             
        }

#       w <- .getW(w)
        stopifnot(is.matrix(w))
        d <- dim(w)
        if (prod(d) == 0) { stop('ncol and nrow of w must be > 0') }
        if (min(d %% 2) == 0) { stop('w must have uneven sides') }      

        # to get the weights in the (by row) order for the C routine
        # but keeping nrow and ncol as-is
        w[] <- as.vector(t(w))
        out <- raster(x)
        filename <- trim(filename)

        padrows <- FALSE
        if (pad) {
                padrows <- TRUE
        }
        gll <- as.integer(.isGlobalLonLat(out))
        if (gll) {
                pad <- TRUE
        }
        if (NAonly) {
                na.rm <- TRUE
        }

        dofun <- TRUE
        domean <- FALSE
        if (missing(fun)) {
                dofun <- FALSE
                domean <- FALSE
        } else {
                fun2 <- .makeTextFun(fun)
                if (is.character(fun2)) {
                        if (fun2=='mean') {
                                domean <- TRUE
                                dofun <- FALSE
                        } else if (fun2 == 'sum') {
                                dofun <- FALSE
                        }
                }
        }
        if (dofun) {
                e <- new.env()
                if (na.rm) {
                        runfun <- function(x) as.double( fun(x, na.rm=TRUE) )
                } else {
                        runfun <- function(x) as.double( fun(x) )
                }
        }
        NAonly <- as.integer(NAonly)
        narm <- as.integer(na.rm)
        domean <- as.integer(domean)

        if (canProcessInMemory(out)) {
                if (pad) {
                        # this should be done in C, but for now....
                        f <- floor(d / 2)
                        v <- as.matrix(x)
                        if (padrows) {
                                padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1])
                                v <- rbind(padRows, v, padRows)
                        } 
                        if (gll) {
                                v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]])       
                        } else {
                                padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2])
                                v <- cbind(padCols, v, padCols)
                        }

                        paddim <- as.integer(dim(v))
                        if (dofun) {
                                v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                        v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE)
                        if (padrows) {
                                v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] 
                        } else {
                                v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))]                  
                        }
                        v <- as.vector(t(v))

                } else {

                        if (dofun) {
                                v <- .Call('focal_fun', values(x), w, as.integer(dim(out)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', values(x), w, as.integer(dim(out)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                }

                out <- setValues(out, v)
                if (filename  != '') {
                        out <- writeRaster(out, filename, ...)
                }

        } else {
                out <- writeStart(out, filename,...)
                tr <- blockSize(out, minblocks=3, minrows=3)
                pb <- pbCreate(tr$n, label='focal', ...)
                addr <- floor(nrow(w) / 2)
                addc <- floor(ncol(w) / 2)
                nc <- ncol(out)
                nc1 <- 1:(nc * addc)

                if (pad) {
                        f <- floor(d / 2)
                        v <- getValues(x, row=1, nrows=tr$nrows[1]+addr)
                        v <- matrix(v, ncol=ncol(out), byrow=TRUE)
                        if (padrows) {
                                padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1])
                                v <- rbind(padRows, v, padRows)
                        }
                        if (gll) {
                                v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]])                       
                        } else {
                                padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2])
                                v <- cbind(padCols, v, padCols)
                        }
                        paddim <- as.integer(dim(v))
                        if (dofun) {
                                v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                        v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE)
                        if (padrows) {
                                v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] 
                        } else {
                                v <- v[ , -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))]                         
                        }
                        v <- as.vector(t(v))
                        out <- writeValues(out, v, 1)
                        pbStep(pb)

                        for (i in 2:(tr$n-1)) {
                                v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr))
                                v <- matrix(v, ncol=ncol(out), byrow=TRUE)
                                if (padrows) {
                                        padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1])
                                        v <- rbind(padRows, v, padRows)
                                }
                                if (gll) {
                                        v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]])                       
                                } else {                                
                                        padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2])
                                        v <- cbind(padCols, v, padCols)
                                }
                                paddim <- as.integer(dim(v))
                                if (dofun) {
                                        v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                                } else {
                                        v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                                }
                                v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE)
                                if (padrows) {
                                        v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] 
                                } else {
                                        v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))]                          
                                }
                                v <- as.vector(t(v))
                                out <- writeValues(out, v[-nc1], tr$row[i])
                                pbStep(pb) 
                        }
                        i <- tr$n
                        v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr)
                        v <- matrix(v, ncol=ncol(out), byrow=TRUE)
                        if (padrows) {
                                padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1])
                                v <- rbind(padRows, v, padRows)
                        }
                        if (gll) {
                                v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]])                       
                        } else {
                                padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2])
                                v <- cbind(padCols, v, padCols)
                        }
                        paddim <- as.integer(dim(v))
                        if (dofun) {
                                v <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                        v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE)
                        if (padrows) {
                                v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] 
                        } else {
                                v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))]                          
                        }
                        v <- as.vector(t(v))

                        out <- writeValues(out, v[-nc1], tr$row[i])
                        pbStep(pb) 

                } else {

                        v <- getValues(x, row=1, nrows=tr$nrows[1]+addr)
                        if (dofun) {
                                v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[1]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[1]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                        out <- writeValues(out, v, 1)
                        pbStep(pb)
                        for (i in 2:(tr$n-1)) {
                                v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr))
                                if (dofun) {
                                        v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                                } else {
                                        v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                                }
                                out <- writeValues(out, v[-nc1], tr$row[i])
                                pbStep(pb) 
                        }
                        i <- tr$n
                        v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr)
                        if (dofun) {
                                v <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
                        } else {
                                v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
                        }
                        out <- writeValues(out, v[-nc1], tr$row[i])
                        pbStep(pb) 
                }
                out <- writeStop(out)                   
                pbClose(pb)     
        }
        return(out)
}
)

97 focalWeight.R

# Author: Robert J. Hijmans
# Date : June 2013
# Version 1.0
# Licence GPL v3
.circular.weight <- function(rs, d) {
        nx <- 1 + 2 * floor(d/rs[1])
        ny <- 1 + 2 * floor(d/rs[2])
        m <- matrix(ncol=nx, nrow=ny)
        m[ceiling(ny/2), ceiling(nx/2)] <- 1
        if (nx == 1 & ny == 1) {
                return(m)
        } else {
                x <- raster(m, xmn=0, xmx=nx*rs[1], ymn=0, ymx=ny*rs[2], crs='+proj=utm +zone=1')
                d <- as.matrix(distance(x)) <= d
                d / sum(d)
        }
}
.Gauss.weight <- function(rs, sigma) {
        if (length(sigma) == 1) {
                d <- 3 * sigma
        } else {
                d <- sigma[2]
                sigma <- sigma[1]
        }
        nx <- 1 + 2 * floor(d/rs[1])
        ny <- 1 + 2 * floor(d/rs[2])
        m <- matrix(ncol=nx, nrow=ny)
        xr <- (nx * rs[1]) / 2
        yr <- (ny * rs[2]) / 2
        r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
        p <- xyFromCell(r, 1:ncell(r))^2
# according to http://en.wikipedia.org/wiki/Gaussian_filter
        m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2))
        m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)
# sum of weights should add up to 1     
        m / sum(m)
}
.rectangle.weight <- function(rs, d) {
        d <- rep(d, length.out=2)
        nx <- 1 + 2 * floor(d[1]/rs[1])
        ny <- 1 + 2 * floor(d[2]/rs[2])
        m <- matrix(1, ncol=nx, nrow=ny)
        m / sum(m)
}
focalWeight <- function(x, d, type=c('circle', 'Gauss', 'rectangle')) {
        type <- match.arg(type)
        x <- res(x)
        if (type == 'circle') {
                .circular.weight(x, d[1])
        } else if (type == 'Gauss') {
                if (!length(d) %in% 1:2) {
                        stop(If type=Gauss, d should be a vector of length 1 or 2)
                }
                .Gauss.weight(x, d)
        } else {
                .rectangle.weight(x, d)
        }
}
..simple.circular.weight <- function(radius) {
# based on a function provided by Thomas Cornulier
        x <- -radius:radius
        n <- length(x)
    d <- sqrt(rep(x, n)^2 + rep(x, each=n)^2) <= radius
    matrix(d + 0, n, n) / sum(d)
}
..simple.Gauss.weight <- function(n, sigma) {
# need to adjust for non-square cells to distance.... 
        m <- matrix(ncol=n, nrow=n)
        col <- rep(1:n, n)
        row <- rep(1:n, each=n)
        x <- col - ceiling(n/2)
        y <- row - ceiling(n/2)
# according to http://en.wikipedia.org/wiki/Gaussian_filter
        m[cbind(row, col)] <- 1/(2*pi*sigma^2) * exp(-(x^2+y^2)/(2*sigma^2))
# sum of weights should add up to 1     
        m / sum(m)
}

98 fourCellsFromXY.R

# Author: Robert J. Hijmans
# Date :  March  2009, August 2012
# Licence GPL v3
# updated November 2011
# version 1.0
fourCellsFromXY <- function(object, xy, duplicates=TRUE) {
# if duplicates is TRUE, the same cell number can be returned 
# twice (if point in the middle of division between two cells) or
# four times (if point in center of cell)
        r <- raster(object) # use small object
        stopifnot(is.matrix(xy))
        cells <- cellFromXY(r, xy)
        rows <- rowFromCell(r, cells)
        cols <- colFromCell(r, cells)
        cellsXY <- xyFromCell(r, cells)
        if (duplicates) {
                pos <- matrix(0, ncol=ncol(xy), nrow=nrow(xy))
                pos[ xy[,1] > cellsXY[,1], 1 ] <- 1
                pos[ xy[,1] < cellsXY[,1], 1 ] <- -1
                pos[ xy[,2] < cellsXY[,2], 2 ] <- 1
                pos[ xy[,2] > cellsXY[,2], 2 ] <- -1
        } else {
                pos <- matrix(-1, ncol=ncol(xy), nrow=nrow(xy))
                pos[ xy[,1] > cellsXY[,1], 1 ] <- 1
                pos[ xy[,2] < cellsXY[,2], 2 ] <- 1
        }


        poscol <- cols + pos[,1]
        if (.isGlobalLonLat(r)) {
                poscol[poscol==0] <- ncol(r)
                poscol[poscol==ncol(r)+1] <- 1
        } else {
                poscol[poscol==0] <- 2
                poscol[poscol==ncol(r)+1] <- ncol(r) - 1
        }

        posrow <- rows + pos[,2]
        posrow[posrow==0] <- 2
        posrow[posrow==nrow(r)+1] <- nrow(r) - 1
        four <- matrix(cells, ncol=4, nrow=nrow(xy))
        four[,2] <- cellFromRowCol(r, posrow, cols)
        four[,3] <- cellFromRowCol(r, posrow, poscol)
        four[,4] <- cellFromRowCol(r, rows, poscol)

        return(four)
}

99 frbind.R

# Author: Robert J. Hijmans
# Date : November 2011
# Version 1.0
# Licence GPL v3
# friendly rbind
# rbinds data.frames with different column names
.frbind <- function(x, ...) {
        if (! inherits(x, 'data.frame') ) {
                x <- data.frame(x)
        }
        d <- list(...)
        if (length(d) == 0) { return(x) }

        for (i in 1:length(d)) {

                dd <- d[[i]]
                if (! inherits(dd, 'data.frame')) {
                        dd <- data.frame(dd)
                }

                cnx <- colnames(x)
                cnd <- colnames(dd)

                e <- cnx[(cnx %in% cnd)]        
                for (j in e) {
                        if (class(x[,j]) != class(dd[,j])) {
                                x[,j] <- as.character(x[,j])
                                dd[,j] <- as.character(dd[,j])
                        }
                }

                a <- which(!cnd %in% cnx)
                if (length(a) > 0) {
                        zz <- dd[NULL, a, drop=FALSE]
                        zz[1:nrow(x),] <- NA
                        x <- cbind(x, zz)
                }
                b <- which(!cnx %in% cnd)
                if (length(b) > 0) {
                        zz <- x[NULL, b, drop=FALSE]
                        zz[1:nrow(dd),] <- NA
                        dd <- cbind(dd, zz)
                }

                x <- rbind(x, dd)               
        }
        x
}

100 freq.R

# Author: Robert J. Hijmans
# Date : March 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(freq)) {
        setGeneric(freq, function(x, ...)
                standardGeneric(freq))
}
setMethod('freq', signature(x='RasterLayer'), 
        function(x, digits=0, value=NULL, useNA=ifany, progress='', ...) {

                if (!is.null(value)) {
                        return(.count(x, value, digits=digits, progress=progress, ...))
                }

                if (canProcessInMemory(x, 3)) {

                        d <- round(getValues(x), digits=digits)
                        res <- table( d, useNA=useNA )

                } else {

                        tr <- blockSize(x, n=2)
                        pb <- pbCreate(tr$n, progress=progress, label='freq')   
                        z <- vector(length=0)
                        for (i in 1:tr$n) {
                                d <- round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits)
                                res <- table(d, useNA=useNA )
                                res <- cbind(as.numeric(unlist(as.vector(dimnames(res)))), as.vector(res))
                                z <- rbind(z, res)
                                pbStep(pb, i)
                        }
                        res <- tapply(z[,2], z[,1], sum)        
                        pbClose(pb)             
                }

                res <- cbind(as.numeric(unlist(as.vector(dimnames(res)))), as.vector(res))
                colnames(res) <- c('value', 'count')
                return(res)
        }
)
setMethod('freq', signature(x='RasterStackBrick'), 
        function(x, digits=0, value=NULL, useNA=ifany, merge=FALSE, progress='', ...) {
                if (!is.null(value)) {
                        return(.count(x, value, digits=digits, progress=progress, ...))
                }

                nl <- nlayers(x)
                res <- list()

                pb <- pbCreate(nl, progress=progress, label='freq')     
                for (i in 1:nl) { 
                        res[[i]] <- freq( raster(x, i), useNA=useNA, progress='', ...) 
                        pbStep(pb, i)
                }
                pbClose(pb)

                names(res) <- ln <- names(x)

                if (merge) {
                        r <- res[[1]]
                        colnames(r)[2] <- ln[1]
                        if (nl > 1) {                   
                                for (i in 2:nl) {
                                        x <- res[[i]]
                                        colnames(x)[2] <- ln[i]
                                        r <- merge(r, x, by=1, all=TRUE)
                                }
                        }
                        return(r)
                }

                return(res)
        }
)
.count <- function(x, value, digits=0, progress='', ...) {
        value <- value[1]

        if (nlayers(x) > 1) {

                if (canProcessInMemory(x, 2)) {
                        if (is.na(value)) {
                                v <-  colSums(is.na(getValues(x)))
                        } else {
                                v <- round(getValues(x), digits=digits) == value
                                v <- colSums(v, na.rm=TRUE)
                        }
                } else {
                        tr <- blockSize(x, n=2)
                        pb <- pbCreate(tr$n, progress=progress)
                        v <- 0
                        for (i in 1:tr$n) {
                                vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                if (is.na(value)) {
                                        v <- v + colSums(is.na(vv))
                                } else {
                                        vv <- round(v, digits=digits) == value
                                        v <- v + colSums(vv, na.rm=TRUE)
                                }
                                pbStep(pb, i)
                        }
                        pbClose(pb)
                }
                return(v)       

        } else {

                if (canProcessInMemory(x, 2)) {
                        if (is.na(value)) {
                                x <- sum(is.na(getValues(x)))
                        } else {
                                v <- na.omit(round(getValues(x), digits=digits))
                                x <- sum(v == value)
                        }
                        return(x)
                } else {
                        tr <- blockSize(x, n=2)
                        pb <- pbCreate(tr$n, progress=progress)
                        r <- 0
                        for (i in 1:tr$n) {
                                v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                if (is.na(value)) {
                                        r <- r + sum(is.na(v))
                                } else {
                                        v <- na.omit(round(v, digits=digits))
                                        r <- r + sum(v == value)
                                }
                                pbStep(pb, i)
                        }
                        pbClose(pb)
                        return(r)
                }
        }
}

101 fullFileName.R

# raster package
# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  September 2009
# Version 0.9
# Licence GPL v3
# this function adds the working directory to a filename, if the filename has no path name 
# and, thus, presumably exists in the working directory.
# Storing the full file name is to avoid that a filename becomes invalid if the working directory 
# changes during an R session
.fullFilename <- function(x, expand=FALSE) {
        x <- trim(x)
        if (identical(basename(x), x)) {
                x <- file.path(getwd(), x)
        }
        if (expand) {
                x <- path.expand(x)
        }
        return(x)
}

102 gainoffset.R

# Author: Robert J. Hijmans
# Date : September 2010
# Version 1.0
# Licence GPL v3
'gain<-' <- function(x, value) {
        value <- as.numeric(value[1])
        if (inherits(x, 'RasterStack')) {
                x@layers <- lapply( x@layers, 
                        function(z) {
                                if (fromDisk(x)) {
                                        z@data@gain <- value
                                } else {
                                        z <- z * value
                                }
                                return(z)
                        } 
                )
        } else {
                if (fromDisk(x)) {
                        x@data@gain <- value
                } else {
                        x <- x * value
                }
        }
        return(x)
}
gain <- function(x) {
        if (inherits(x, 'RasterStack')) {
                r <- sapply( x@layers, function(z) { z@data@gain } )
        } else {
                r <- x@data@gain                
        }
        return(r)
}
'offs<-' <- function(x, value) {
        value <- as.numeric(value[1])
        if (inherits(x, 'RasterStack')) {

                x@layers <- lapply( x@layers, 
                        function(z) { 

                                if (fromDisk(z)) {
                                        z@data@offset <- value
                                } else {
                                        z <- z + offset
                                }
                                return(z) 
                        } 
                )

        } else {
                if (fromDisk(x)) {
                        x@data@offset <- value  
                } else {
                        x <- x + value
                }
        }
        return(x)
}
offs <- function(x) {
        if (inherits(x, 'RasterStack')) {
                r <- sapply( x@layers, function(z) { z@data@offset } )
        } else {
                r <- x@data@offset 
        }
        return(r)
}

103 gdalFormats.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
.isSupportedFormat <- function(dname) {
        res <- dname %in% c(.nativeDrivers(), 'ascii', 'big.matrix', 'CDF')
        if (!res) { 
                res <- .isSupportedGDALFormat(dname) 
        } 
        return(res)
}
.gdalWriteFormats <- function() {
        .requireRgdal()
        gd <- rgdal::gdalDrivers()
        gd <- as.matrix( gd[gd[,3] == T, ] )
        i <- which(gd[,1] %in% c('VRT', 'MEM', 'MFF', 'MFF2'))
        gd[-i,]
}
.isSupportedGDALFormat <- function(dname) {
        .requireRgdal()
        gd <- .gdalWriteFormats()
        res <- dname %in% gd[,1]
        if (!res) { stop(paste(dname, is not a supported file format. See writeFormats() ) ) }
        return(res)
}
#.GDALDataTypes <- c('Unknown', 'Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', '
# what are these?  CInt16', 'CInt32',   'CFloat32', 'CFloat64')  as in C?
# this needs to get fancier; depending on object and the abilties of the drivers
.getGdalDType <- function(dtype, format='') {
        if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S'))) {
                stop('not a valid data type')
        }
        if (dtype == 'INT1S') { # gdal does not have this
                warning('data type INT1S is not available in GDAL. Changed to INT2S (you may prefer INT1U (Byte))')
                dtype <- 'INT2S'
        }
        type <- .shortDataType(dtype)
        size <- dataSize(dtype) * 8
        if (format=='BMP' | format=='ADRG' | format=='IDA' | format=='SGI') {
                return('Byte')
        }
        if (format=='PNM') {
                if (size == 8) {
                        return('Byte')
                } else {
                        return('UInt16')
                }
        }
        if (format=='RMF') {
                if (type == 'FLT') {
                        return('Float64')
                }
        }

        if (type == 'LOG') {
                warning('data type LOG is not available in GDAL. Changed to INT1U')
                return('Byte')
        }
        if (type == 'INT') { 
                type <- 'Int' 
                if (size == 64) {
                        size <- 32
                        warning('8 byte integer values not supported by rgdal, changed to 4 byte integer values')
                }
                if (! dataSigned(dtype) ) {
                        if (size == 8) {
                                return('Byte')
                        } else {
                                type <- paste('U', type, sep='')
                        }
                }
        } else { 
                type <- 'Float' 
        }
        return(paste(type, size, sep=''))
}
.getRasterDType <- function(dtype) {
        if (!(dtype %in% c('Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', 'CInt16', 'CInt32', 'CFloat32', 'CFloat64'))) {
                return ('FLT4S')
        } else if  (dtype == 'Byte') {
                return('INT1U')
        } else if  (dtype == 'UInt16') {
                return('INT2U')
        } else if  (dtype == 'Int16' | dtype == 'CInt16') {
                return('INT2S')
        } else if  (dtype == 'UInt32') {
                return('INT4U')
        } else if  (dtype == 'Int32' | dtype == 'CInt32') {
                return('INT4S')
        } else if  (dtype == 'Float32' | dtype == 'CFloat32' ) {
                return('FLT4S')
        } else if  (dtype == 'Float64' | dtype == 'CFloat64' )  {
                return('FLT8S')
        } else {
                return('FLT4S') 
        }
}

104 gdal.R

# Author: Robert J. Hijmans
# Date : September 2012
# Version 1.0
# Licence GPL v3
.requireRgdal <- function(stopIfAbsent=TRUE) {

        y <- getOption('rasterGDALLoaded')
        w <- getOption('warn')
        options('warn'=-1) 
        x <- isTRUE( try( require(rgdal, quietly=TRUE ) ) )
        options('warn'= w) 

        if (! isTRUE(y) ) {

                if (x) {
                        #pkg.info <- utils::packageDescription('rgdal') 
                        #test <- utils::compareVersion(pkg.info[[Version]], 0.7-21) > 0
                        #if (!test) {
                        #       stop('you use rgdal version: ', pkg.info[[Version]], '\nYou need version 0.7-22 or higher')
                        #}
                        options('rasterGDALLoaded'=TRUE)
                        return(TRUE)

                } else if (stopIfAbsent) {
                        stop(package 'rgdal' is not available)
                } else {
                        return(FALSE)
                }
        }


        return(TRUE)
}

105 GDALtransient.R

# Author: Robert J. Hijmans
# contact: r.hijmans@gmail.com
# Date : January 2009
# Version 0.9
# Licence GPL v3
# based on  create2GDAL and rgdal::saveDataset from the rgdal package
# authors: Timothy H. Keitt, Roger Bivand, Edzer Pebesma, Barry Rowlingson
.getGDALtransient <- function(r, filename, options, NAflag, ...)  {
        .GDALnodatavalue <- function(x){
                if (x == 'Float32') return(-3.4E38)
                if (x == 'Float64') return(-1.7E308)
                if (x == 'Int32') return(-2147483647)
                if (x == 'Int16') return(-32768)
                if (x == 'Int8') return(-128)
                if (x == 'Byte') return(255)
                if (x == 'UInt16') return(65535)
                if (x == 'UInt32') return(2147483647) #(4294967295) <- not supported as integer in R
                stop('cannot find matching nodata value')
        }
    nbands <- nlayers(r)
        ct <- r@legend@colortable
        if (length(ct) > 0 ) {
                hasCT <- TRUE
        } else {
                hasCT <- FALSE
        }
        r <- raster(r)
        datatype <- .datatype(...)
        overwrite <- .overwrite(...)
        gdalfiletype <- .filetype(filename=filename, ...)
        .isSupportedFormat(gdalfiletype)

        if (filename == ) {     
                stop('provide a filename')      
        }
        if (file.exists( filename))  {
                if (!overwrite) {
                        stop(filename exists; use overwrite=TRUE)
                } else if (!file.remove( filename)) {
                        stop(cannot delete existing file. permission denied.)
                }
        }       
        dataformat <- .getGdalDType(datatype, gdalfiletype)

        if (dataformat != 'Byte') hasCT <- FALSE

        if (missing(NAflag)) { 
                NAflag <- .GDALnodatavalue(dataformat) 
        }

        if (gdalfiletype=='GTiff') {
                bytes <- ncell(r) * dataSize(datatype) * nbands
                if (bytes > (4 * 1024 * 1024 * 1000) ) {  # ~ 4GB
                        options <- c(options, 'BIGTIFF=YES')
                }
                options <- c(options, COMPRESS=LZW)
        }
        driver <- new(GDALDriver, gdalfiletype)

    transient <- try( new(GDALTransientDataset, driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL), silent=TRUE)
        if (class(transient) == 'try-error') {
                if (dataformat == Float64) {
                        dataformat <- Float32
                }
            transient <- new(GDALTransientDataset, driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL)
        }
        for (i in 1:nbands) {
                b <- new(GDALRasterBand, transient, i)
                rgdal::GDALcall(b, SetNoDataValue, NAflag)
                if (hasCT) {
                        rgdal::GDALcall(b, SetRasterColorTable, t(col2rgb(ct, TRUE)))
                }
        }

        if (rotated(r)) {
                gt <- r@rotation@geotrans
        } else {
                #if (flip) {
                #       gt <- c(xmin(r), xres(r), 0, 0, ymax(r), yres(r))               
                #       cat('flipping (this creates an invalid RasterLayer)\n')
                #} else {
                gt <- c(xmin(r), xres(r), 0, ymax(r), 0, -yres(r))
                #}
        }
        rgdal::GDALcall(transient, SetGeoTransform, gt)
        # as.character to ensure NA is character
        rgdal::GDALcall(transient, SetProject, as.character(projection(r))) 
        if (is.null(options)) {
                options <- ''
        }
        return(list(transient, NAflag, options, dataformat))
}

106 Geary.R

# Author: Robert J. Hijmans
# Date : April 2011
# Version 1.0
# Licence GPL v3
.getFilter <- function(w, warn=TRUE) {
        if (!is.matrix(w)) {
                w <- .checkngb(w)
                w <- matrix(1, nrow=w[1], ncol=(w[2]))
                w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0
        } else {
                if (w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] != 0) {
                        if (warn) {
                                warning('central cell of weights matrix (filter) was set to zero')
                        }
                        w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0
                }               
                stopifnot(all(w >= 0))
        }
        if (min(dim(w) %% 2)==0) {
                stop('dimensions of weights matrix (filter) must be uneven')
        }
        w
}


Geary <- function(x, w= matrix(1, 3, 3)) {
        w <- .getFilter(w, warn=FALSE)

        i <- trunc(length(w)/2)+1 
        n <- ncell(x) - cellStats(x, 'countNA')

        fun <- function(x,...) sum(w*(x-x[i])^2, ...)
        w2 <- w
        w2[] <- 1
        Eij <- cellStats(focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE), sum)    
        if (sum(! unique(w) %in% 0:1) > 0) {
                x <- calc(x, fun=function(x) ifelse(is.na(x), NA ,1))
                W <- focal(x, w=w, na.rm=TRUE, pad=TRUE ) 
        } else {
                w[w==0] <- NA
                W <- focal(x, w=w, fun=function(x, ...){  sum(!is.na(x)) }, pad=TRUE )
        }
        z <- 2 * cellStats(W, sum) * cellStats((x - cellStats(x, mean))^2, sum)

        (n-1)*Eij/z
}
GearyLocal <- function(x,  w=matrix(1, 3, 3)) { 
        w <- .getFilter(w)
        i <- trunc(length(w)/2)+1 
        fun <- function(x,...) sum(w*(x-x[i])^2, ...)
        w2 <- w
        w2[] <- 1
        Eij <- focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE)
        s2 <-  cellStats(x, sd)^2 
        if (ncell(x) < 1000000) { n <- ncell(x) - cellStats(x, 'countNA' )
        } else { n <- ncell(x) }

        s2 <- (s2 * (n-1)) / n 
        Eij / s2
}

107 getData.R

# Download geographic data and return as R object
# Author: Robert J. Hijmans, r.hijmans@gmail.com
# License GPL3
# Version 0.9
# October 2008
getData <- function(name='GADM', download=TRUE, path='', ...) {
        path <- .getDataPath(path)
        if (name=='GADM') {
                .GADM(..., download=download, path=path)
        } else if (name=='SRTM') {
                .SRTM(..., download=download, path=path)
        } else if (name=='alt') {
                .raster(..., name=name, download=download, path=path)
        } else if (name=='worldclim') {
                .worldclim(..., download=download, path=path)
        } else if (name=='CMIP5') {
                .cmip5(..., download=download, path=path)
        } else if (name=='ISO3') {
                ccodes()[,c(2,1)]
        } else if (name=='countries') {
                .countries(download=download, path=path, ...)
        } else {
                stop(name, ' not recognized as a valid name.')
        }
}
.download <- function(aurl, filename) {
        fn <- paste(tempfile(), '.download', sep='')
        res <- download.file(url=aurl, destfile=fn, method=auto, quiet = FALSE, mode = wb, cacheOK = TRUE)
        if (res == 0) {
                w <- getOption('warn')
                on.exit(options('warn' = w))
                options('warn'=-1) 
                if (! file.rename(fn, filename) ) { 
                        # rename failed, perhaps because fn and filename refer to different devices
                        file.copy(fn, filename)
                        file.remove(fn)
                }
        } else {
                stop('could not download the file' )
        }
}
.ISO <- function() {
   ccodes()
}
ccodes <- function() {
        path <- paste(system.file(package=raster), /external, sep='')
        d <- read.csv(paste(path, /countries.csv, sep=), stringsAsFactors=FALSE, encoding=UTF-8)
        return(as.matrix(d))
}
.getCountry <- function(country='') {
        country <- toupper(trim(country[1]))
#       if (nchar(country) < 3) {
#               stop('provide a 3 letter ISO country code')
#       }
        cs <- ccodes()
        try (cs <- toupper(cs))
        iso3 <- substr(toupper(country), 1, 3)
        if (iso3 %in% cs[,2]) {
                return(iso3)
        } else {
                iso2 <- substr(toupper(country), 1, 3)
                if (iso2 %in% cs[,3]) {
                        i <- which(country==cs[,3])
                        return( cs[i,2] )
                } else if (country %in% cs[,1]) {
                        i <- which(country==cs[,1])
                        return( cs[i,2] )
                } else {
                        stop('provide a valid name or 3 letter ISO country code; you can get a list with: getData(ISO3)')
                }
        }
}
.getDataPath <- function(path) {
        path <- trim(path)
        if (path=='') {
                path <- .dataloc()
        } else {
                if (substr(path, nchar(path)-1, nchar(path)) == '//' ) {
                        p <- substr(path, 1, nchar(path)-2)             
                } else if (substr(path, nchar(path), nchar(path)) == '/'  | substr(path, nchar(path), nchar(path)) == '\\') {
                        p <- substr(path, 1, nchar(path)-1)
                } else {
                        p <- path
                }
                if (!file.exists(p) & !file.exists(path)) {
                        stop('path does not exist: ', path)
                }
        }
        if (substr(path, nchar(path), nchar(path)) != '/' & substr(path, nchar(path), nchar(path)) != '\\') {
                path <- paste(path, /, sep=)
        }
        return(path)
}
.GADM <- function(country, level, download, path) {
#       if (!file.exists(path)) {  dir.create(path, recursive=T)  }
        country <- .getCountry(country)
        if (missing(level)) {
                stop('provide a level= argument; levels can be 0, 1, or 2 for most countries, and higer for some')
        }

        filename <- paste(path, country, '_adm', level, .RData, sep=)
        if (!file.exists(filename)) {
                if (download) {
                        theurl <- paste(http://biogeo.ucdavis.edu/data/gadm2/R/, country, '_adm', level, .RData, sep=)
                        .download(theurl, filename)
                        if (!file.exists(filename))     { 
                                cat(\nCould not download file -- perhaps it does not exist \n) 
                        }
                } else {
                        cat(\nFile not available locally. Use 'download = TRUE'\n)
                }
        }       
        if (file.exists(filename)) {
                thisenvir = new.env()
                data <- get(load(filename, thisenvir), thisenvir)
                return(data)
        } 
}
.countries <- function(download, path, ...) {
#       if (!file.exists(path)) {  dir.create(path, recursive=T)  }
        filename <- paste(path, 'countries.RData', sep=)
        if (!file.exists(filename)) {
                if (download) {
                        theurl <- paste(http://biogeo.ucdavis.edu/data/diva/misc/countries.RData, sep=)
                        .download(theurl, filename)
                        if (!file.exists(filename)) {
                                cat(\nCould not download file -- perhaps it does not exist \n) 
                        }
                } else {
                        cat(\nFile not available locally. Use 'download = TRUE'\n)
                }
        }       
        if (file.exists(filename)) {
                thisenvir = new.env()
                data <- get(load(filename, thisenvir), thisenvir)
                return(data)
        } 
}
.cmip5 <- function(var, model, rcp, year, res, lon, lat, path, download=TRUE) {
        if (!res %in% c(2.5, 5, 10)) {
                stop('resolution should be one of: 2.5, 5, 10')
        }
        if (res==2.5) { res <- '2-5' }
        var <- tolower(var[1])
        vars <- c('tmin', 'tmax', 'prec', 'bio')
        stopifnot(var %in% vars)
        var <- c('tn', 'tx', 'pr', 'bi')[match(var, vars)]

        model <- toupper(model)
        models <- c('AC', 'BC', 'CC', 'CE', 'CN', 'GF', 'GD', 'GS', 'HD', 'HG', 'HE', 'IN', 'IP', 'MI', 'MR', 'MC', 'MP', 'MG', 'NO')
        stopifnot(model %in% models)

        rcps <- c(26, 45, 60, 85)
        stopifnot(rcp %in% rcps)
        stopifnot(year %in% c(50, 70))

        m <- matrix(c(0,1,1,0,1,1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,1,0,1,1,1,0,0,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4)
        i <- m[which(model==models), which(rcp==rcps)]
        if (!i) {
                warning('this combination of rcp and model is not available')
                return(invisible(NULL))
        }

        path <- paste(path, '/cmip5/', res, 'm/', sep='')
        dir.create(path, recursive=TRUE, showWarnings=FALSE)
        zip <- tolower(paste(model, rcp, var, year, '.zip', sep=''))
        theurl <- paste('http://biogeo.ucdavis.edu/data/climate/cmip5/', res, 'm/', zip, sep='')
        zipfile <- paste(path, zip, sep='')
        if (var == 'bi') {
                n <- 19
        } else {
                n <- 12
        }
        tifs <- paste(extension(zip, ''), 1:n, '.tif', sep='')
        files <- paste(path, tifs, sep='')
        fc <- sum(file.exists(files))
        if (fc < n) {
                if (!file.exists(zipfile)) {
                        if (download) {
                                .download(theurl, zipfile)
                                if (!file.exists(zipfile))      { 
                                        cat(\n Could not download file -- perhaps it does not exist \n) 
                                }
                        } else {
                                cat(\nFile not available locally. Use 'download = TRUE'\n)
                        }
                }       
                unzip(zipfile, exdir=dirname(zipfile))
        }
        stack(paste(path, tifs, sep=''))
}
#.cmip5(var='prec', model='BC', rcp=26, year=50, res=10, path=getwd())
.worldclim <- function(var, res, lon, lat, path, download=TRUE) {
        if (!res %in% c(0.5, 2.5, 5, 10)) {
                stop('resolution should be one of: 0.5, 2.5, 5, 10')
        }
        if (res==2.5) { res <- '2-5' }
        stopifnot(var %in% c('tmean', 'tmin', 'tmax', 'prec', 'bio', 'alt'))
        path <- paste(path, 'wc', res, '/', sep='')
        dir.create(path, showWarnings=FALSE)
        if (res==0.5) {
                lon <- min(180, max(-180, lon))
                lat <- min(90, max(-60, lat))
                rs <- raster(nrows=5, ncols=12, xmn=-180, xmx=180, ymn=-60, ymx=90 )
                row <- rowFromY(rs, lat) - 1
                col <- colFromX(rs, lon) - 1
                rc <- paste(row, col, sep='') 
                zip <- paste(var, '_', rc, '.zip', sep='')
                zipfile <- paste(path, zip, sep='')
                if (var  == 'alt') {
                        bilfiles <- paste(var, '_', rc, '.bil', sep='')
                        hdrfiles <- paste(var, '_', rc, '.hdr', sep='')                 
                } else if (var  != 'bio') {
                        bilfiles <- paste(var, 1:12, '_', rc, '.bil', sep='')
                        hdrfiles <- paste(var, 1:12, '_', rc, '.hdr', sep='')
                } else {
                        bilfiles <- paste(var, 1:19, '_', rc, '.bil', sep='')
                        hdrfiles <- paste(var, 1:19, '_', rc, '.hdr', sep='')           
                }
                theurl <- paste('http://biogeo.ucdavis.edu/data/climate/worldclim/1_4/tiles/cur/', zip, sep='')
        } else {
                zip <- paste(var, '_', res, 'm_bil.zip', sep='')
                zipfile <- paste(path, zip, sep='')
                if (var  == 'alt') {
                        bilfiles <- paste(var, '.bil', sep='')
                        hdrfiles <- paste(var, '.hdr', sep='')                  
                } else if (var  != 'bio') {
                        bilfiles <- paste(var, 1:12, '.bil', sep='')
                        hdrfiles <- paste(var, 1:12, '.hdr', sep='')
                } else {
                        bilfiles <- paste(var, 1:19, '.bil', sep='')
                        hdrfiles <- paste(var, 1:19, '.hdr', sep='')    
                }
                theurl <- paste('http://biogeo.ucdavis.edu/data/climate/worldclim/1_4/grid/cur/', zip, sep='')
        }
        files <- c(paste(path, bilfiles, sep=''), paste(path, hdrfiles, sep=''))
        fc <- sum(file.exists(files))
        if (fc < 24) {
                if (!file.exists(zipfile)) {
                        if (download) {
                                .download(theurl, zipfile)
                                if (!file.exists(zipfile))      { 
                                        cat(\n Could not download file -- perhaps it does not exist \n) 
                                }
                        } else {
                                cat(\nFile not available locally. Use 'download = TRUE'\n)
                        }
                }       
                unzip(zipfile, exdir=dirname(zipfile))
                for (h in paste(path, hdrfiles, sep='')) {
                        x <- readLines(h)
                        x <- c(x[1:14], 'PIXELTYPE     SIGNEDINT', x[15:length(x)])
                        writeLines(x, h)
                }
        }
        if (var  == 'alt') {
                st <- raster(paste(path, bilfiles, sep=''))
        } else {
                st <- stack(paste(path, bilfiles, sep=''))
        }
        projection(st) <- +proj=longlat +datum=WGS84
        return(st)
}
.raster <- function(country, name, mask=TRUE, path, download, keepzip=FALSE, ...) {
        country <- .getCountry(country)
        path <- .getDataPath(path)
        if (mask) {
                mskname <- '_msk_'
                mskpath <- 'msk_'
        } else {
                mskname<-'_'
                mskpath <- ''           
        }
        filename <- paste(path, country, mskname, name, .grd, sep=)
        if (!file.exists(filename)) {
                zipfilename <- filename
                extension(zipfilename) <- '.zip'
                if (!file.exists(zipfilename)) {
                        if (download) {
                                theurl <- paste(http://biogeo.ucdavis.edu/data/diva/, mskpath, name, /, country, mskname, name, .zip, sep=)
                                .download(theurl, zipfilename)
                                if (!file.exists(zipfilename))  { 
                                        cat(\nCould not download file -- perhaps it does not exist \n) 
                                }
                        } else {
                                cat(\nFile not available locally. Use 'download = TRUE'\n)
                        }
                }
                ff <- unzip(zipfilename, exdir=dirname(zipfilename))
                if (!keepzip) {
                        file.remove(zipfilename)
                }
        }       
        if (file.exists(filename)) { 
                rs <- raster(filename)
        } else {
                #patrn <- paste(country, '.', mskname, name, .grd, sep=)
                #f <- list.files(path, pattern=patrn)
                f <- ff[substr(ff, nchar(ff)-3, nchar(ff)) == '.grd']
                if (length(f)==0) {
                        warning('something went wrong')
                        return(NULL)
                } else if (length(f)==1) {
                        rs <- raster(f)
                } else {
                        rs <- sapply(f, raster)
                        cat('returning a list of RasterLayer objects\n')
                        return(rs)
                }
        }
        projection(rs) <- +proj=longlat +datum=WGS84
        return(rs)      
}
.SRTM <- function(lon, lat, download, path) {
        stopifnot(lon >= -180 & lon <= 180)
        stopifnot(lat >= -60 & lat <= 60)

        rs <- raster(nrows=24, ncols=72, xmn=-180, xmx=180, ymn=-60, ymx=60 )
        rowTile <- rowFromY(rs, lat)
        colTile <- colFromX(rs, lon)
        if (rowTile < 10) { rowTile <- paste('0', rowTile, sep='') }
        if (colTile < 10) { colTile <- paste('0', colTile, sep='') }

        f <- paste('srtm_', colTile, '_', rowTile, sep=)
        zipfilename <- paste(path, /, f, .ZIP, sep=)
        tiffilename <- paste(path, /, f, .TIF, sep=)

        if (!file.exists(tiffilename)) {
                if (!file.exists(zipfilename)) {
                        if (download) { 
                                theurl <- paste(ftp://xftp.jrc.it/pub/srtmV4/tiff/, f, .zip, sep=)
                                test <- try (.download(theurl, zipfilename) , silent=TRUE)
                                if (class(test) == 'try-error') {
                                        theurl <- paste(http://hypersphere.telascience.org/elevation/cgiar_srtm_v4/tiff/zip/, f, .ZIP, sep=)
                                        test <- try (.download(theurl, zipfilename) , silent=TRUE)
                                        if (class(test) == 'try-error') {
                                                theurl <- paste(http://srtm.csi.cgiar.org/SRT-ZIP/SRTM_V41/SRTM_Data_GeoTiff/, f, .ZIP, sep=)
                                                .download(theurl, zipfilename)
                                        }
                                }
                        } else {cat('file not available locally, use download=TRUE\n') }        
                }
                if (file.exists(zipfilename)) { 
                        unzip(zipfilename, exdir=dirname(zipfilename))
                        file.remove(zipfilename)
                }       
        }
        if (file.exists(tiffilename)) { 
                rs <- raster(tiffilename)
                projection(rs) <- +proj=longlat +datum=WGS84
                return(rs)
        } else {
                stop('file not found')
        }
}

108 getValuesBlock.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 1.0
# Licence GPL v3
if (!isGeneric(getValuesBlock)) {
        setGeneric(getValuesBlock, function(x, ...)
                standardGeneric(getValuesBlock))
}       
setMethod('getValuesBlock', signature(x='RasterStack'), 
        function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) {
                stopifnot(hasValues(x))
                stopifnot(row <= x@nrows)
                stopifnot(col <= x@ncols)
                stopifnot(nrows > 0)
                stopifnot(ncols > 0)
                row <- max(1, min(x@nrows, round(row[1])))
                lastrow <- min(x@nrows, row + round(nrows[1]) - 1)
                nrows <- lastrow - row + 1
                col <- max(1, min(x@ncols, round(col[1])))
                lastcol <- col + round(ncols[1]) - 1
                ncols <- lastcol - col + 1

                nlyrs <- nlayers(x)
                if (missing(lyrs)) {
                        lyrs <- 1:nlyrs
                } else {
                        lyrs <- lyrs[lyrs %in% 1:nlyrs]
                        if (length(lyrs) == 0) {
                                stop(no valid layers selected)
                        }
                        nlyrs <- length(lyrs)
                        x <- x[[lyrs]]
                }

                startcell <- cellFromRowCol(x, row, col)
                lastcell <- cellFromRowCol(x, lastrow, lastcol)
                nc <- ncol(x)
                res <- matrix(ncol=nlyrs, nrow=nrows * ncols)

                inmem <- sapply(x@layers, function(x) x@data@inmemory)
                if (any(inmem)) {
                        if (col==1 & ncols==nc) {
                                cells <- startcell:lastcell
                        }
                        cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
                }

                for (i in 1:nlyrs) {
                        xx <- x@layers[[lyrs[i]]]
                        if ( inMemory(xx) ) {                   
                                res[,i] <- xx@data@values[cells]                
                        } else {
                                res[,i] <- .readRasterLayerValues(xx, row, nrows, col, ncols)
                        }
                }

                colnames(res) <- names(x)
                res
        }
)
setMethod('getValuesBlock', signature(x='RasterBrick'), 
        function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) {
                stopifnot(hasValues(x))
                row <- max(1, round(row))
                col <- max(1, round(col))
                stopifnot(row <= x@nrows)
                stopifnot(col <= x@ncols)
                nrows <- min(round(nrows), x@nrows-row+1)               
                ncols <- min((x@ncols-col+1), round(ncols))
                stopifnot(nrows > 0)
                stopifnot(ncols > 0)

                nlyrs <- nlayers(x)
                if (missing(lyrs)) {
                        lyrs <- 1:nlyrs
                } else {
                        lyrs <- lyrs[lyrs %in% 1:nlyrs]
                        if (length(lyrs) == 0) {
                                stop(no valid layers)
                        }
                        nlyrs <- length(lyrs)
                }


                if ( inMemory(x) ){
                        lastrow <- row + nrows - 1
                        if (col==1 & ncols==x@ncols) {
                                rnge <- cellFromRowCol(x, c(row, lastrow), c(1, ncol(x)))
                                res <- x@data@values[rnge[1]:rnge[2], , drop=FALSE]
                        } else {
                                lastcol <- col + ncols - 1
                                res <- x@data@values[cellFromRowColCombine(x, row:lastrow, col:lastcol), , drop=FALSE]
                        }
                        if (NCOL(res) > nlyrs) {
                                res <- res[, lyrs, drop=FALSE]
                        }
                        colnames(res) <- names(x)[lyrs]

                } else if ( fromDisk(x) ) {
                        res <- .readRasterBrickValues(x, row, nrows, col, ncols)
                        if (NCOL(res) > nlyrs) {
                                res <- res[, lyrs, drop=FALSE]
                        }

                } else { # no data
                        res <- ( matrix(rep(NA, nrows * ncols * nlyrs), ncol=nlyrs) )
                        colnames(res) <- names(x)[lyrs]
                }
                return(res)
        }
)
setMethod('getValuesBlock', signature(x='RasterLayer'), 
        function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='') {

                row <- max(1, min(x@nrows, round(row[1])))
                lastrow <- min(x@nrows, row + round(nrows[1]) - 1)
                nrows <- lastrow - row + 1
                col <- max(1, min(x@ncols, round(col[1])))
                lastcol <- col + round(ncols[1]) - 1
                ncols <- lastcol - col + 1

                startcell <- cellFromRowCol(x, row, col)
                lastcell <- cellFromRowCol(x, lastrow, lastcol)
                if (!(validRow(x, row))) {      stop(paste(row, 'is not a valid rownumber')) }

                if ( inMemory(x) ) {
                        if (col==1 & ncols==ncol(x)) {
                                res <- x@data@values[startcell:lastcell]
                        } else {
                                cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
                                res <- x@data@values[cells]
                        }
                } else if ( fromDisk(x)) {
                        res <- .readRasterLayerValues(x, row, nrows, col, ncols)

                } else  { # no values
                        res <- rep(NA, nrows * ncols)                   
                }

                if (format=='matrix') {
                        res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE )
                        colnames(res) <- col:lastcol
                        rownames(res) <- row:lastrow
                }
                res
        }

)
setMethod('getValuesBlock', signature(x='RasterLayerSparse'), 
        function(x=1, row, nrows=1, col=1, ncols=(ncol(x)-col+1), format='') {

                row <- max(1, min(x@nrows, round(row[1])))
                lastrow <- min(x@nrows, row + round(nrows[1]) - 1)
                nrows <- lastrow - row + 1
                col <- max(1, min(x@ncols, round(col[1])))
                lastcol <- col + round(ncols[1]) - 1
                ncols <- lastcol - col + 1

                startcell <- cellFromRowCol(x, row, col)
                lastcell <- cellFromRowCol(x, lastrow, lastcol)
                if (!(validRow(x, row))) {      stop(paste(row, 'is not a valid rownumber')) }

                if ( inMemory(x) ) {
                        i <- which(x@index >= startcell & x@index <= lastcell)
                        if (length(i) > 0) {
                                res <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
                                m <- match(i, res)
                                res[] <- NA
                                res[m] <- x@data@values[i]
                        } else {
                                res <- rep(NA, nrows * ncols)
                        }       
                } else if ( fromDisk(x) ) {
                        # not yet implemented
                        #if (! fromDisk(x)) {
                        #       return(rep(NA, times=(lastcell-startcell+1)))
                        #}
                        #res <- .readRasterLayerValues(x, row, nrows, col, ncols, is.open)

                } else  {
                        res <- rep(NA, nrows * ncols)                   
                } 


                if (format=='matrix') {
                        res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE )
                        colnames(res) <- col:lastcol
                        rownames(res) <- row:lastrow
                }
                res
        }

)

109 getValuesFocal.R

# Author: Robert J. Hijmans
# Date :  March 2012
# Version 1.0
# Licence GPL v3
if (!isGeneric(getValuesFocal)) {
        setGeneric(getValuesFocal, function(x, row, nrows, ngb, ...)
                standardGeneric(getValuesFocal))
}       
setMethod(getValuesFocal, signature(x='Raster', row='missing', nrows='missing', ngb='numeric'), 
function(x, ngb, names=FALSE, ...) {
        getValuesFocal(x, 1, nrow(x), ngb, names=names, ...)
})
setMethod(getValuesFocal, signature(x='Raster', row='numeric', nrows='numeric', ngb='numeric'), 
function(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) {
        nl <- nlayers(x)
        if (nl == 0) {
                stop(x has no values)
        } else if (nl > 1) {
                mm <- list()
        }
        xx <- raster(x)
        nc <- ncol(xx)
        row <- round(row)
        nrows <- round(nrows)
        if (!validRow(xx, row)) {
                stop(Not a valid row number)
        }
        if ( (row+nrows-1) > nrow(xx) ) {
                stop('nrows' is too high)
        }
        stopifnot(is.atomic(padValue))
        geo <- couldBeLonLat(xx)

        mask <- FALSE
        if (is.matrix(ngb)) {
                w <- ngb
                ngb <- dim(w)
                w <- ! is.na(as.vector(t(w)))
                mask <- TRUE
        }
        ngb <- .checkngb(ngb, mustBeOdd=TRUE)

        ngbr <- floor(ngb[1]/2)
        ngbc <- floor(ngb[2]/2)


        startrow <- row-ngbr
        endrow <- row+nrows-1+ngbr

        sr <- max(1, startrow)  # startrow
        er <- min(endrow, nrow(xx))
        if (nl==1) {
                vv <- matrix(getValues(x, sr, (er-sr+1)), ncol=1)
        } else {
                vv <- getValues(x, sr, (er-sr+1))
        }

        for (i in 1:nl) {
                v <- matrix(vv[,i], ncol=nc, byrow=TRUE)
                if (sr > startrow) {
                        add <- sr - startrow
                        v <- rbind(matrix(padValue, nrow=add, ncol=ncol(v)), v)
                }
                if (endrow > er) {
                        add <- endrow - er
                        v <- rbind(v, matrix(padValue, nrow=add, ncol=ncol(v)))
                }

                if (geo) {
                        nv <- ncol(v)
                        if (ngbc < nv) {
                                v <- cbind(v[,(nv-ngbc+1):nv], v, v[,1:ngbc])
                        } else {
                                stop('horizontal neighbourhood is too big')
                        }
                } else {
                        add <- matrix(padValue, ncol=ngbc, nrow=nrow(v))
                        v <- cbind(add, v, add)
                }

                v <- .Call('focal_get', as.vector(t(v)), as.integer(dim(v)), as.integer(ngb), NAOK=TRUE, PACKAGE='raster')
                m <- matrix(v, nrow=nrows*nc, byrow=TRUE)
                if (names) {
                        rownames(m) <- cellFromRowCol(xx, row, 1):cellFromRowCol(xx, row+nrows-1,nc)
                        colnames(m) <- paste('r', rep(1:ngb[1], each=ngb[2]), 'c', rep(1:ngb[2], ngb[1]), sep='')
                }
                if (mask) {
                        m <- m[,mask,drop=FALSE]
                }
                if (nl == 1) {
                        return(m)
                } else {
                        mm[[i]] <- m
                }
        }
        if (array) {
                if (names) {
                        dnms <- list(rownames(mm[[1]]), colnames(mm[[1]]), names(x))
                } else {
                        dnms <- list(NULL, NULL, names(x))
                }
                mm <- array(unlist(mm), c(nrow(mm[[1]]), ncol(mm[[1]]), length(mm)), dimnames=dnms )
        } else  {
                names(mm) <- names(x)
        }
        return(mm)
}
)

110 getValues.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(getValues)) {
        setGeneric(getValues, function(x, row, nrows, ...)
                standardGeneric(getValues))
}       
setMethod(getValues, signature(x='RasterLayer', row='missing', nrows='missing'), 
function(x, format='') {

        cr <- c(x@ncols, x@nrows)
#       f <- is.factor(x)
#       if (f) {
#               labs <- labels(x)
#       }

        if ( inMemory(x) ) {
                x <- x@data@values
        } else if ( fromDisk(x) ) {
                x <- .readRasterLayerValues(x, 1, x@nrows)
        } else {
                x <- rep(NA, ncell(x))
        }
        if (format=='matrix') { 
                return ( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) )
        #} else if (format =='array') {
        #       return( array( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE), dim=c(cr, 1)) )

#       } else if (f) {
#               x <- factor(x)
                # set labels?
        }
        return( x ) 
}
)
setMethod(getValues, signature(x='RasterBrick', row='missing', nrows='missing'), 
function(x) {
        if (! inMemory(x) ) {
                if ( fromDisk(x) ) {
                        x <- readAll(x)
                } else {
                        return( matrix(rep(NA, ncell(x) * nlayers(x)), ncol=nlayers(x)) )
                }
        }
        colnames(x@data@values) <- names(x)
        x@data@values
}
)
setMethod(getValues, signature(x='RasterStack', row='missing', nrows='missing'), 
function(x) {
        m <- matrix(nrow=ncell(x), ncol=nlayers(x))
        colnames(m) <- names(x)
        for (i in 1:nlayers(x)) {
                m[,i] <- getValues(x@layers[[i]])
        }
        m
}
)
setMethod(getValues, signature(x='RasterLayerSparse', row='missing', nrows='missing'), 
function(x, format='') {

        cr <- c(x@ncols, x@nrows)

        if ( inMemory(x) ) {
                i <- x@index
                v <- x@data@values
                x <- rep(NA, ncell(x))
                x[i] <- v
        } else if ( fromDisk(x) ) {
                # not yet implemented
                ### x <- .readRasterLayerValues(x, 1, x@nrows)
        } else {
                x <- rep(NA, ncell(x))
        }
        if (format=='matrix') { 
                x <- matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) 
        }       
        return( x ) 
}
)

111 getValuesRows.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='missing'), 
        function(x, row, nrows) {
                getValues(x, row=row, nrows=1)
        }
)
setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='numeric'), 
function(x, row, nrows) {
        for (i in 1:nlayers(x)) {
                if (i==1) {
                        v <- getValues(x@layers[[i]], row, nrows)
                        res <- matrix(ncol=nlayers(x), nrow=length(v))
                        res[,1] <- v
                } else {
                        res[,i] <- getValues(x@layers[[i]], row, nrows)
                }
        }
        colnames(res) <- names(x)
        res
}
)
setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='missing'), 
        function(x, row, nrows) {
                getValues(x, row=row, nrows=1)
        }
)
setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='numeric'), 
function(x, row, nrows, format='') {
        row <- round(row)
        nrows <- round(nrows)
        stopifnot(validRow(x, row))
        stopifnot(nrows > 0)
        row <- min(x@nrows, max(1, row))
        endrow <- max(min(x@nrows, row+nrows-1), row)
        nrows <- endrow - row + 1

        if (inMemory(x)){
                startcell <- cellFromRowCol(x, row, 1)
                endcell <- cellFromRowCol(x, row+nrows-1, x@ncols)
                v <-  x@data@values[startcell:endcell] 
        } else if ( fromDisk(x) ) {
                v <- .readRasterLayerValues(x, row, nrows) 
        } else {
                v <- rep(NA, nrows * x@ncols) 
        }
        if (format=='matrix') { 
                v <- matrix(v, nrow=nrows, byrow=TRUE) 
                rownames(v) <- row:(row+nrows-1)
                colnames(v) <- 1:ncol(v)
        } 
        return(v)
}
)
setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='missing'), 
        function(x, row, nrows) {
                getValues(x, row=row, nrows=1)
        }
)
setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='numeric'), 
function(x, row, nrows) {
        if (! validRow(x, row)) { 
                stop(row, ' is not a valid rownumber') 
        }
        row <- min(x@nrows, max(1, round(row)))
        endrow <- max(min(x@nrows, row+round(nrows)-1), row)
        nrows <- endrow - row + 1
        if ( inMemory(x) ){
                startcell <- cellFromRowCol(x, row, 1)
                endcell <- cellFromRowCol(x, row+nrows-1, x@ncols)
                res <- x@data@values[startcell:endcell, ,drop=FALSE]
        } else if (fromDisk(x)) {
                res <- .readRasterBrickValues(x, row, nrows)
        } else {
                res <- matrix(NA, nrow=nrows*ncol(x), ncol=nlayers(x))
        }
        colnames(res) <- names(x)
        res
}
)
setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='missing'), 
        function(x, row, nrows) {
                getValues(x, row=row, nrows=1)
        }
)
setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='numeric'), 
function(x, row, nrows, format='') {
        row <- round(row)
        nrows <- round(nrows)
        stopifnot(validRow(x, row))
        stopifnot(nrows > 0)
        row <- min(x@nrows, max(1, row))
        endrow <- max(min(x@nrows, row+nrows-1), row)
        nrows <- endrow - row + 1

        if (inMemory(x)){
                i <- which(x@index >= startcell & x@index <= lastcell)
                if (length(i) > 0) {
                        v <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
                        m <- match(i, v)
                        v[] <- NA
                        v[m] <- x@data@values[i]        
                } else {
                        v <- rep(NA, nrows * x@ncols) 
                }
        } else if ( fromDisk(x) ) {
                # not yet implemented
                ## v <- .readRasterLayerValues(x, row, nrows) 
        } else {
                v <- rep(NA, nrows * x@ncols) 
        }
        if (format=='matrix') { 
                v <- matrix(v, nrow=nrows, byrow=TRUE) 
                rownames(v) <- row:(row+nrows-1)
                colnames(v) <- 1:ncol(v)
        } 
        return(v)
}
)

112 gridDistance2.R

# Author: Robert J. Hijmans
# Date :  December 2011
# Version 1.0
# Licence GPL v3
.gridDistance2 <- function(x, filename='', ...) {
# currently only works for planar data! 
        rs <- res(x)
        xdist <- rs[1]
        ydist <- rs[2]
        xydist <- sqrt(xdist^2 + ydist^2)
        z1 <- z2 <- raster(x)
        nc <- ncol(z1)
        filename <- trim(filename)

        if (canProcessInMemory(z1)) {
                f <- rep(Inf, nc)
                z1a <- z2a <- raster(x)
                x <- getValues(x)
                a <- as.integer(dim(z1))
                b <- c(xdist, ydist, xydist)
                z1a[] <- .Call('broom', x, f, a , b, as.integer(1), NAOK=TRUE, PACKAGE='raster')
                z2a[] <- .Call('broom', x, f, a , b, as.integer(0), NAOK=TRUE, PACKAGE='raster')
                x <- min(z1a, z2a)
                if (filename != '') {
                        x <- writeRaster(x, filename, ...)
                }
        } else {
                tr <- blockSize(z1)
                pb <- pbCreate(tr$n*2, ...)
                z1 <- writeStart(z1, rasterTmpFile())
                i <- 1
                v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                f <- rep(Inf, nc)
                z <- .Call('broom', v,  f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster')
                z1 <- writeValues(z1, z, tr$row[i])
                f <- z[(length(z)-nc+1):length(z)]
                for (i in 2:tr$n) {
                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster')
                        z1 <- writeValues(z1, z, tr$row[i])
                        f <- z[(length(z)-nc+1):length(z)]
                        pbStep(pb, i)
                }
                z1 <- writeStop(z1)

                z2 <- writeStart(z2, rasterTmpFile())
                i <- tr$n
                v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                f <- rep(Inf, nc)
                z <- .Call('broom', v,  f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster')
                z2 <- writeValues(z2, z, tr$row[i])
                f <- z[1:nc]
                for (i in (tr$n-1):1) {
                        v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                        z <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster')
                        z2 <- writeValues(z2, z, tr$row[i])
                        f <- z[1:nc]
                        pbStep(pb, i)
                }
                z2 <- writeStop(z2)
                x <- calc(stack(z1, z2), fun=min, filename=filename)
                file.remove(filename(z1))
                file.remove(filename(z2))
        }
        return(x)
}

113 gridDistance.R

# Author: Jacob van Etten
# email jacobvanetten@yahoo.com
# Date :  May 2010
# Version 1.1
# Licence GPL v3
# RH: updated for igraph (from igraph0)
# sept 23, 2012
if (!isGeneric(gridDistance)) {
        setGeneric(gridDistance, function(x, ...)
                standardGeneric(gridDistance))
}       
setMethod(gridDistance, signature(RasterLayer), 
function(x, origin, omit=NULL, filename=, ...) {
        if( !require(igraph)) {
                stop('you need to install the igraph0 package to be able to use this function')
        }
        if (missing(origin)) {
                stop(you must supply an 'origin' argument)
        }
        if (! hasValues(x) ) {
                stop('cannot compute distance on a RasterLayer with no data')
        }
        lonlat <- couldBeLonLat(x)
        filename <- trim(filename)

        if (filename !=   & file.exists(filename)) {
                if (! .overwrite(...)) {
                        stop(file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it)
                }
        }

        # keep canProcessInMemory for debugging
        # need to test more to see how much igraph can deal with
        if ( canProcessInMemory(x, n=10) ) { 
                out <- raster(x)
                x <- getValues(x) # to avoid keeping values in memory twice

                oC <- which(x %in% origin) 
                ftC <- which(!(x %in% omit))
                v <- .calcDist(out, ncell(out), ftC, oC, lonlat=lonlat)
                v[is.infinite(v)] <- NA

                out <- setValues(out, v)
                if (filename != ) {
                        out <- writeRaster(out, filename, ...)
                }
                return(out)

        } else  {

                tr <- blockSize(x, n=1)
                pb <- pbCreate(tr$n*2 - 1, ...)
                #going up
                r1 <- writeStart(raster(x), rasterTmpFile(), overwrite=TRUE)
                for (i in tr$n:1) {
                        chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) 
                        startCell <- (tr$row[i]-1) * ncol(x)
                        chunkSize <- length(chunk)
                        oC <- which(chunk %in% origin) 
                        ftC <- which(!(chunk %in% omit))
                        if (length(ftC) != 0) {
                                if (i < tr$n) {
                                        firstRowftC <- firstRowftC + chunkSize 
                                        chunkDist <- .calcDist(x, 
                                                                chunkSize=chunkSize + ncol(x), 
                                                                ftC=c(ftC, firstRowftC), 
                                                                oC=c(oC, firstRowftC), 
                                                                perCell=c(rep(0,times=length(oC)),firstRowDist), 
                                                                startCell=startCell,
                                                                lonlat=lonlat)[1:chunkSize]
                                } else {
                                        chunkDist <- .calcDist(x, chunkSize=chunkSize, 
                                                                ftC=ftC, oC=oC, perCell=0,
                                                                startCell=startCell, lonlat=lonlat)
                                }
                        } else {
                                if (i < tr$n) {
                                        firstRowftC <- firstRowftC + chunkSize 
                                }
                                chunkDist <- rep(NA, tr$nrows[i] * ncol(r1))
                        }
                        firstRow <- chunk[1:ncol(x)]
                        firstRowDist <- chunkDist[1:ncol(x)]
                        firstRowftC <- which(!(firstRow %in% omit))
                        firstRowDist <- firstRowDist[firstRowftC]
                        chunkDist[is.infinite(chunkDist)] <- NA
                        r1 <- writeValues(r1, chunkDist, tr$row[i])
                        pbStep(pb) 
                }
                r1 <- writeStop(r1)

                #going down

                out <- writeStart(raster(x), filename=filename, overwrite=TRUE, ...)                    
                for (i in 1:tr$n) {
                        chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) 
                        chunkSize <- length(chunk)
                        startCell <- (tr$row[i]-1) * ncol(x)
                        oC <- which(chunk %in% origin) 
                        ftC <- which(!(chunk %in% omit))

                        if (length(ftC) != 0) {

                                if (i > 1) {
                                        chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) 
                                        chunkDist[is.na(chunkDist)] <- Inf 

                                        chunkDist <- pmin(chunkDist,
                                                .calcDist(x, chunkSize=chunkSize+ncol(x), 
                                                        ftC = c(lastRowftC, ftC+ncol(x)), 
                                                        oC = c(lastRowftC, oC+ncol(x)), 
                                                        perCell = c(lastRowDist, rep(0,times=length(oC))), 
                                                        startCell = startCell - ncol(x),
                                                        lonlat=lonlat)[-(1:ncol(r1))])

                                } else {
                                        chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i])
                                        chunkDist[is.na(chunkDist)] <- Inf

                                        chunkDist <- pmin(chunkDist,
                                                .calcDist(x, chunkSize=chunkSize, 
                                                        ftC=ftC, oC=oC, perCell=0, 
                                                        startCell=startCell, lonlat=lonlat))
                                }
                        } else {                        
                                chunkDist <- rep(NA, tr$nrows[i] * ncol(out))                                           
                        }
                        lastRow <- chunk[(length(chunk)-ncol(x)+1):length(chunk)]
                        lastRowDist <- chunkDist[(length(chunkDist)-ncol(x)+1):length(chunkDist)]
                        lastRowftC <- which(!(lastRow %in% omit))
                        lastRowDist <- lastRowDist[lastRowftC]
                        chunkDist[is.infinite(chunkDist)] <- NA
                        out <- writeValues(out, chunkDist, tr$row[i])
                        pbStep(pb) 
                }
                out <- writeStop(out)
                pbClose(pb)
                return(out)
        }
}
)
.calcDist <- function(x, chunkSize, ftC, oC, perCell=0, startCell=0, lonlat) {

        if (length(oC) > 0) {
                #adj <- adjacency(x, fromCells=ftC, toCells=ftC, directions=8)
                adj <- adjacent(x, ftC, directions=8, target=ftC, pairs=TRUE)
                startNode <- max(adj)+1 #extra node to serve as origin
                adjP <- rbind(adj, cbind(rep(startNode, times=length(oC)), oC))
                distGraph <- igraph::graph.edgelist(adjP, directed=TRUE)
                if (length(perCell) == 1) {
                        if (perCell == 0) {
                                perCell <- rep(0, times=length(oC))
                        }
                }
                if (lonlat) {
                        distance <- pointDistance(xyFromCell(x,adj[,1]+startCell), xyFromCell(x,adj[,2]+startCell), longlat=TRUE) 
                        igraph::E(distGraph)$weight <- c(distance, perCell)
                } else {
                        sameRow <- which(rowFromCell(x, adj[,1]) == rowFromCell(x, adj[,2]))
                        sameCol <- which(colFromCell(x, adj[,1]) == colFromCell(x, adj[,2]))
                        igraph::E(distGraph)$weight <- sqrt(xres(x)^2 + yres(x)^2)
                        igraph::E(distGraph)$weight[sameRow] <- xres(x)
                        igraph::E(distGraph)$weight[sameCol] <- yres(x)
                        igraph::E(distGraph)$weight[(length(adj[,1])+1):(length(adj[,1])+length(oC))] <- perCell
                }

                shortestPaths <- igraph::shortest.paths(distGraph, startNode)
                shortestPaths <- shortestPaths[-(length(shortestPaths))] #chop startNode off

                if (length(shortestPaths) < chunkSize) { 
                        #add Inf values where shortest.paths() leaves off before completing all nodes
                        shortestPaths <- c(shortestPaths, rep(Inf, times=chunkSize-length(shortestPaths))) 
                }

        } else {
                shortestPaths <- rep(Inf, times=chunkSize)
        }

        return(shortestPaths)
}

114 hdrBIL.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2009
# Version 0.9
# Licence GPL v3

.writeHdrBIL <- function(x, layout='BIL') {
        hdrfile <- x@file@name
        extension(hdrfile) <- '.hdr'
        thefile <- file(hdrfile, w)  # open an txt file connectionis
        cat(NROWS          ,  x@nrows, \n, file = thefile)
        cat(NCOLS          ,  x@ncols, \n, file = thefile)
        cat(NBANDS         ,  nlayers(x), \n, file = thefile)
        cat(NBITS          ,  dataSize(x@file@datanotation) * 8, \n, file = thefile)
        btorder <- ifelse(x@file@byteorder == little, I, M)
        cat(BYTEORDER      , btorder, \n, file = thefile)

#  PIXELTYPE should work for Gdal, and perhpas ArcGIS, see:
# http://lists.osgeo.org/pipermail/gdal-dev/2006-October/010416.html    
        dtype <- .shortDataType(x@file@datanotation)
        if (dtype == 'INT' | dtype == 'LOG' ) { 
                pixtype <- ifelse(dataSigned(x@file@datanotation), SIGNEDINT, UNSIGNEDINT)
        } else { 
                pixtype <- FLOAT 
        }
        cat(PIXELTYPE      , pixtype, \n, file = thefile)       
        cat(LAYOUT         , layout, \n, file = thefile)
    cat(SKIPBYTES       0\n, file = thefile)
    cat(ULXMAP         , as.character(xmin(x) + 0.5 * xres(x)), \n, file = thefile) 
    cat(ULYMAP         , as.character(ymax(x) - 0.5 * yres(x)), \n, file = thefile) 
        cat(XDIM           , xres(x), \n, file = thefile)
        cat(YDIM           , yres(x), \n, file = thefile)
        browbytes <- round(ncol(x) * dataSize(x@file@datanotation) )
        cat(BANDROWBYTES   , browbytes, \n, file = thefile)
        cat(TOTALROWBYTES  , browbytes *  nbands(x), \n, file = thefile)
        cat(BANDGAPBYTES    0\n, file = thefile)
    cat(NODATA         , .nodatavalue(x), \n, file = thefile)   
        cat(\n\n, file = thefile)
        cat(The below is additional metadata, not part of the BIL/HDR format\n, file = thefile)
        cat(----------------------------------------------------------------\n, file = thefile)
        cat(CREATOR=R package:x\n, file = thefile)
        cat(CREATED=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile)
        cat(Projection=, projection(x), \n, file = thefile)
        cat(MinValue=,  minValue(x), \n, file = thefile)
        cat(MaxValue=,  maxValue(x), \n, file = thefile)
        close(thefile)
        return(invisible(TRUE)) 
}

115 hdrBov.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : December 2009
# Version 0.9
# Licence GPL v3
.writeHdrBOV <- function(raster) {
        hdrfile <- filename(raster)
        extension(hdrfile) <- '.bov'
        thefile <- file(hdrfile, w)  # open an txt file connectionis
        cat(TIME: 1.23456, \n, file = thefile)
        datf <- filename(raster)
        extension(datf) <- '.gri'
        cat(DATA_FILE:, datf, \n, file = thefile)
        cat(DATA_SIZE:, nrow(raster), ncol(raster), nlayers(raster), \n, file = thefile)

        dtype <- substr(raster@file@datanotation, 1, 3)
        if (dtype == 'INT' | dtype == 'LOG' ) { 
                pixtype <- INT
        } else { 
                pixtype <- FLOAT 
        }
        cat(DATA_FORMAT:, pixtype, \n, file = thefile)
        cat(VARIABLE: , basename(filename(raster)),  \n, file = thefile)
        cat(BYTEORDER , toupper(.Platform$endian), \n, file = thefile)
        cat(CENTERING: zonal, \n, file = thefile)
        cat(BRICK_ORIGIN:, xmin(raster), ymin(raster), 0., \n, file = thefile)
        cat(BRICK_SIZE:, xres(raster), yres(raster), 1., \n, file = thefile)
        close(thefile)
        return(invisible(TRUE)) 
}

116 hdrEnvi.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2009
# Version 0.9
# Licence GPL v3

.writeHdrENVI <- function(r) {
        hdrfile <- filename(r)
        extension(hdrfile) <- .hdr
        thefile <- file(hdrfile, w) 
        cat(ENVI\n, file = thefile)
        cat(description = {, names(r), }, \n, file = thefile)
        cat(samples = , ncol(r), \n, file = thefile)            
        cat(lines = , nrow(r), \n, file = thefile)              
        cat(bands = , r@file@nbands, \n, file = thefile)                
        cat(header offset = 0\n, file = thefile)                
        cat(file type = ENVI Standard\n, file = thefile)                
        dsize <- dataSize(r@file@datanotation)
        if (.shortDataType(r@file@datanotation) == 'INT') {
                if (dsize == 1) { dtype <- 1
                } else if (dsize == 2) { dtype <- 2
                } else if (dsize == 4) { dtype <- 3
                } else if (dsize == 8) { dtype <- 14
                } else { stop('what?')
                }
        } else {
                if (dsize == 4) { dtype <- 4
                } else if (dsize == 8) { dtype <- 5
                } else { stop('what?')
                }
        }       
        cat(data type = , dtype, \n, file = thefile)
#1=8-bit byte; 2=16-bit signed integer; 3=32-bit signed long integer; 4=32-bit floating point; 
#5=64-bit double-precision floating point; 6=2x32-bit complex, real-imaginary pair of double precision;
#9=2x64-bit double-precision complex, real-imaginary pair of double precision; 12=16-bit unsigned integer; 
#13=32-bit unsigned long integer; 14=64-bit signed long integer; and 15=64-bit unsigned long integer.
        cat(interleave = , r@file@bandorder, \n, file = thefile)        
        cat(sensor type = \n, file = thefile)           

        btorder <- as.integer(r@file@byteorder != 'little')  # little -> 0, big -> 1
        cat(byte order = , btorder, \n,file = thefile)          
        if (couldBeLonLat(r)) {
                cat(map info = {Geographic Lat/Lon, 1, 1,, xmin(r),, , ymax(r),, , xres(r),, , yres(r), }\n, file = thefile)
        } else {
                cat(map info = {projection, 1, 1,, xmin(r),, , ymax(r),, , xres(r),, , yres(r), }\n, file = thefile)
        }
        if (.requireRgdal(FALSE)) {
                cat(coordinate system string = {, rgdal::showWKT(projection(r)), }\n, file = thefile, sep=)
        } else {
                cat(projection info =, projection(r), \n, file = thefile) 
        }
        cat(z plot range = {, minValue(r),, , maxValue(r), }\n, file = thefile) 
        close(thefile)  
}

117 hdrErdasRaw.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
.writeHdrErdasRaw <- function(raster) {
        hdrfile <- filename(raster)
        extension(hdrfile) <- .raw
        thefile <- file(hdrfile, w)  # open an txt file connectionis
        cat(IMAGINE_RAW_FILE\n, file = thefile)
        cat(PIXEL_FILES , .setFileExtensionValues(raster@file@name), \n, file = thefile)
# this may not work. Some implementations may ignore this keyword and expect the pixelfile to have the same file name, no extension.            
        cat(HEIGHT ,  nrow(raster), \n, file = thefile)
        cat(WIDTH ,  ncol(raster), \n, file = thefile)
        cat(NUM_LAYERS ,  nbands(raster), \n, file = thefile)
        if (.shortDataType(raster@file@datanotation) == 'INT') { 
                dd <- S
        } else { 
                dd <- F 
        }
        nbits <- dataSize(raster@file@datanotation) * 8 
    dtype <- paste(dd, nbits, sep=)
        cat(DATA_TYPE ,  dtype, \n, file = thefile)
#U1, U2, U4, U8, U16, U32
#S16, S32
#F32, and F64.
        if (.Platform$endian == little) { btorder <- LSB 
        } else { btorder <- MSB }
        cat(BYTE_ORDER , btorder, \n, file = thefile)
#Required for DATA_TYPE values of U16, S16, U32, S32
        cat(FORMAT , BIL, \n, file = thefile)
        cat(DATA_OFFSET 0\n, file = thefile)
        cat(END_RAW_FILE\n, file = thefile)

        cat(\n\n, file = thefile)
        cat(The below is additional metadata, not part of the ERDAS raw format\n, file = thefile)
        cat(----------------------------------------------------------------\n, file = thefile)
        cat(CREATOR=R package:raster\n, file = thefile)
        cat(CREATED=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile)
        cat(Projection=, projection(raster), \n, file = thefile)
        cat(MinValue=,  minValue(raster), \n, file = thefile)
        cat(MaxValue=,  maxValue(raster), \n, file = thefile)
        close(thefile)  

        .worldFile(raster, .rww)        
 }

118 hdrIDRISI.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2009
# Version 0.9
# Licence GPL v3

.writeHdrIDRISI <- function(x, old=FALSE) {
        hdrfile <- filename(x)
        hdrfile <- .setFileExtensionHeader(hdrfile, 'IDRISI')
        dtype <- .shortDataType(x@file@datanotation)
        dsize <- dataSize(x)
        if (dataType(x) == 'INT1U') {
                pixtype <- 'byte'
        } else if (dataType(x) == 'INT2S') {
                pixtype <- 'integer'
        } else { 
                pixtype <- 'real'
        }
        if (couldBeLonLat(x)) {
                refsystem <- 'latlong'
                refunits <- 'degrees';
        } else {
                refsystem <- 'plane';
                refunits <- 'm';
        }

        thefile <- file(hdrfile, w)  # open an txt file connectionis
        if (!old) cat('file format : IDRISI Raster A.1\n', file = thefile)
        cat('file title  : ', names(x), \n, sep='', file = thefile)
        cat('data type   : ', pixtype, \n, sep='', file = thefile)
        cat('file type   : binary\n', sep='', file = thefile)
        cat('columns     : ', ncol(x), \n, sep='', file = thefile)
        cat('rows        : ', nrow(x), \n, sep='', file = thefile)
        cat('ref. system : ', refsystem, \n, sep='', file = thefile)
        cat('ref. units  : ', refunits, \n, sep='', file = thefile)
        cat('unit dist.  : 1.0000000', \n, sep='', file = thefile)
        cat('min. X      : ', as.character(xmin(x)), \n, sep='', file = thefile)
        cat('max. X      : ', as.character(xmax(x)), \n, sep='', file = thefile)
        cat('min. Y      : ', as.character(ymin(x)), \n, sep='', file = thefile)
        cat('max. Y      : ', as.character(ymax(x)), \n, sep='', file = thefile)
        cat(pos'n error : unknown\n, file = thefile)
        cat('resolution  : ', xres(x), \n, sep='', file = thefile)
        cat('min. value  : ', minValue(x), \n, sep='', file = thefile)
        cat('max. value  : ', maxValue(x), \n, sep='', file = thefile)
        if (!old) cat('display min : ', minValue(x), \n, sep='', file = thefile)
        if (!old) cat('display max : ', maxValue(x), \n, sep='', file = thefile)
        cat('value units : unspecified\n', file = thefile)
        cat('value error : unknown\n', file = thefile)
        cat('flag value  : ', .nodatavalue(x), \n, sep='', file = thefile)
        cat(flag def'n  : no data\n, file = thefile)
        cat('legend cats : 0\n', file = thefile)
        close(thefile)

        return(invisible(TRUE))
}

119 hdrPRJ.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  April 2011
# Version 1.0
# Licence GPL v3
.writeHdrPRJ <- function(x, ESRI=TRUE) {
        .requireRgdal()
        p4s <- try(     rgdal::showWKT(projection(x), file = NULL, morphToESRI = ESRI) )
        if (class(p4s) != 'try-error') {
                prjfile <- filename(x)
                extension(prjfile) <- '.prj'
                cat(p4s, file=filename)
        } else {
                return(FALSE)
        }
        return(invisible(TRUE))
}

120 hdr.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : October 2008
# Version 0.9
# Licence GPL v3

hdr <- function(x, format, extension='.wld') {
        if (inherits(x, 'RasterStack')) { stop('Only applicable to RasterLayer and RasterBrick classes (and their derivatives)') }
        if (x@file@name == '') { stop('Object has no filename') }
#       if (missing(filename)) {
#               if (x@file@name == '') { 
#                       stop('Object has no filename; please provide a filename= argument') 
#               }
#       } else {
#               fn <- trim(as.character(filename[1]))
#               if (nchar(fn) < 1) {
#                       stop('invalid filename')
#               }
#               x@file@name == fn
#       }

        type <- toupper(format)
        if (type==RASTER) {
                .writeHdrRaster(x)
        } else if (type==WORLDFILE) {
                .worldFile(x, extension)                
        } else if (type==VRT) {
                .writeHdrVRT(x)
                .writeStx(x)            
        } else if (type==BIL) {
                .writeHdrBIL(x)
                .writeStx(x)
        } else if (type==BSQ) {
                .writeHdrBIL(x, BSQ)
                .writeStx(x)
        } else if (type==BIP) {
                .writeHdrBIL(x, BIP)
                .writeStx(x)
        } else if (type==ERDASRAW) {
                .writeHdrErdasRaw(x)
                .writeStx(x)
        } else  if (type==ENVI) {
                .writeHdrENVI(x)
                .writeStx(x)
        } else  if (type==SAGA) {
                .writeHdrSAGA(x)
        } else  if (type==IDRISI) {
                .writeHdrIDRISI(x)
        } else  if (type==IDRISIold) {
                .writeHdrIDRISI(x, old=TRUE)
        } else  if (type==PRJ) {
                .writeHdrPRJ(x, ESRI=TRUE)
        } else {
                stop(This file format is not supported)
        }
        return( invisible(TRUE) )
 }


.writeStx <- function(x, filename='') {
        if (x@data@haveminmax) {
                if (filename=='') {
                        filename <- filename(x)
                } 
                if (filename!='') {
                        extension(filename) <- .stx
                        thefile <- file(filename, w)  # open a txt file connectionis
                        cat(1,  , minValue(x),  , maxValue(x), \n, file = thefile)
                        close(thefile)
                }
        }       
        return( invisible(TRUE) )
}

121 hdrRaster.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 1.0
# Licence GPL v3
.writeHdrRaster <- function(x, type='raster') {
        rastergrd <- .setFileExtensionHeader(filename(x), type)
        thefile <- file(rastergrd, w)  # open an txt file connection
        cat([general], \n, file = thefile)
        cat(creator=R package 'raster', \n, file = thefile)
        cat(created=, format(Sys.time(), %Y-%m-%d %H:%M:%S), \n, file = thefile)
        cat([georeference], \n, file = thefile)
        cat(nrows=,  nrow(x), \n, file = thefile)
        cat(ncols=,  ncol(x), \n, file = thefile)
        cat(xmin=, as.character(xmin(x)), \n, file = thefile)
        cat(ymin=, as.character(ymin(x)), \n, file = thefile)
        cat(xmax=, as.character(xmax(x)), \n, file = thefile)
        cat(ymax=, as.character(ymax(x)), \n, file = thefile)
        cat(projection=, projection(x), \n, file = thefile)
        cat([data], \n, file = thefile)
        cat(datatype=,  x@file@datanotation, \n, file = thefile)
        cat(byteorder=, x@file@byteorder, \n, file = thefile)
        nl <- nlayers(x)
        cat(nbands=,  nl, \n, file = thefile)
        cat(bandorder=,  x@file@bandorder, \n, file = thefile)
        # currently only for single layer files!
        if (nl == 1) {
                fact <- is.factor(x)[1]
                cat(categorical=, paste(fact, collapse=':'), \n, file = thefile)
                if (any(fact)) {
                        r <- x@data@attributes[[1]]
                        cat(ratnames=, paste(colnames(r), collapse=':'), \n, file = thefile)
                        cat(rattypes=, paste(sapply(r, class), collapse=':'), \n, file = thefile)
                        cat(ratvalues=, paste(trim(as.character(as.matrix(r))), collapse=':'), \n, file = thefile)
                } 
        }

#       cat(levels=,  x@data@levels, \n, file = thefile)
        cat(minvalue=,  paste(minValue(x, -1, warn=FALSE), collapse=':'), \n, file = thefile)
        cat(maxvalue=,  paste(maxValue(x, -1, warn=FALSE), collapse=':'), \n, file = thefile)
        cat(nodatavalue=, .nodatavalue(x), \n, file = thefile)
#       cat(Sparse=, x@sparse, \n, file = thefile)
#       cat(nCellvals=, x@data@ncellvals, \n, file = thefile)   
        cat([legend], \n, file = thefile)
        cat(legendtype=,  x@legend@type, \n, file = thefile)
        cat(values=,  paste(x@legend@values, collapse=':'), \n, file = thefile)
        cat(color=,  paste(x@legend@color, collapse=':'), \n, file = thefile)
        cat([description], \n, file = thefile)
        ln <- gsub(:, ., names(x))
        cat(layername=, paste(ln, collapse=':'), \n, file = thefile)
        z <- getZ(x)
        if (! is.null(z)) {
                zname <- names(x@z)[1]
                if (is.null(zname)) {
                        zname <- 'z-value'
                }
                zclass <- class(z)
                z <- as.character(z)
                cat(zvalues=, paste(c(zname, z), collapse=':'), \n, file = thefile)
                cat(zclass=, zclass, \n, file = thefile)
        }

        a <- NULL
        try( a <- unlist(x@history), silent=TRUE )
        if (!is.null(a)) {
                cat(history=, a, \n, file = thefile)
        }

        a <- NULL
        try( a <- rapply(x@history, function(x) paste(as.character(x), collapse='#,#')), silent=TRUE )
        if (!is.null(a)) {
                a <- gsub('\n', '#NL#', a)
                type <- rapply(x@history, class)
                type_value <- apply(cbind(type, a), 1, function(x) paste(x, collapse=':'))
                name_type_value <- apply(cbind(names(a), type_value), 1, function(x) paste(x, collapse='='))
                name_type_value <- paste(name_type_value, '\n', sep='')
                cat([metadata], \n, file = thefile)
                cat(name_type_value, file = thefile)            
        }
        close(thefile)
        return(TRUE)
}

122 hdrSAGA.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2009
# Version 0.9
# Licence GPL v3

.writeHdrSAGA <- function(x) {
        hdrfile <- filename(x)
        hdrfile <- .setFileExtensionHeader(hdrfile, 'SAGA')

        thefile <- file(hdrfile, w)  # open an txt file connectionis
        cat(NAME\t=,  names(x), \n, file = thefile)
        cat(DESCRIPTION\t= \n, file = thefile)
        cat(UNIT\t= \n, file = thefile)

        dtype <- .shortDataType(x@file@datanotation)
        dsize <- dataSize(x@file@datanotation)
        if (dtype == 'INT' ) { 
                if (dsize == 1) {
                        pixtype <- BYTE
                } else if (dsize == 2) {
                        pixtype <- SHORTINT
                } else if (dsize == 4) {
                        pixtype <- INTEGER
                }
                if (! dataSigned(x@file@datanotation)) {
                        pixtype <- paste(pixtype, _UNSIGNED, sep=)
                }
        } else if ( x@file@datanotation == 'FLT4S' ) {
                pixtype <- FLOAT                
        } else {
                stop(paste('cannot write SAGA file with data type:', x@file@datanotation))
        }

        cat(DATAFORMAT\t=, pixtype, \n, file = thefile)

        cat(DATAFILE_OFFSET\t= 0\n, file = thefile)
        cat(BYTEORDER_BIG\t=, x@file@byteorder != 'little', \n, file = thefile)
        cat(POSITION_XMIN\t= ,  as.character(xmin(x) + 0.5 * xres(x)), \n, file = thefile)
        cat(POSITION_YMIN\t= ,  as.character(ymin(x) + 0.5 * yres(x)), \n, file = thefile)
        cat(CELLCOUNT_Y\t= ,  nrow(x), \n, file = thefile)
        cat(CELLCOUNT_X\t= ,  ncol(x), \n, file = thefile)
        cat(CELLSIZE\t= ,  xres(x), \n, file = thefile)
        cat(Z_FACTOR\t= 1.000000\n, file = thefile)
    cat(NODATA_VALUE\t=, .nodatavalue(x), \n, file = thefile)   
    cat(TOPTOBOTTOM\t= TRUE, \n, file = thefile)        
        close(thefile)

        return(invisible(TRUE))
}

123 hdrVRT.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2010
# Version 1.0
# Licence GPL v3

.writeHdrVRT <- function(x) {

        fn <- fname <- x@file@name
        if (tolower(extension(fn)) == '.vrt') {
                stop('cannot (over)write a vrt header for a vrt file')
        }
        if (tolower(extension(fn)) == '.grd') {
                extension(fn) <- '.gri' 
        }
        extension(fname) <- 'vrt'
        pixsize <- dataSize(x@file@datanotation)
        nbands <- nlayers(x)

        bandorder <- x@file@bandorder
        if (bandorder == 'BIL') {
                pixoff <- pixsize
                lineoff <- pixsize * x@ncols * nbands
                imgoff <- ((1:nbands)-1) * x@ncols * pixsize

        } else if (bandorder == 'BSQ') {
                pixoff <- pixsize
                lineoff <- pixsize * x@ncols
                imgoff <- ((1:nbands)-1) *  ncell(x) * pixsize
        } else if (bandorder == 'BIP') {
                pixoff <- pixsize * nbands
                lineoff <- pixsize * x@ncols * nbands
                imgoff <- (1:nbands)-1 
        }
        datatype <- .getGdalDType(x@file@datanotation)  

        if (x@file@byteorder == little) { 
                byteorder <- LSB 
        } else { 
                byteorder <- MSB 
        }
        if (! x@file@toptobottom) { rotation <- 180 } else { rotation <- 0 }
        e <- x@extent
        r <- res(x)
        prj <- projection(x)
        f <- file(fname, w) 
        cat('<VRTDataset rasterXSize=', x@ncols, ' rasterYSize=', x@nrows, '>\n' , sep = , file = f)
        if (rotated(r)) {
                cat('<GeoTransform>', paste(x@rotation@geotrans, collapse=', '), '</GeoTransform>\n', sep = , file = f)
        } else {
                cat('<GeoTransform>', e@xmin, ', ', r[1], ', ', rotation, ', ', e@ymax, ', ', 0.0, ', ', -1*r[2], '</GeoTransform>\n', sep = , file = f)
        }
        if (! is.na(prj) ) {
                cat('<SRS>', prj ,'</SRS>\n', sep = , file = f)
        }

        for (i in 1:nlayers(x)) {
                cat('\t<VRTRasterBand dataType=', datatype, ' band=', i, ' subClass=VRTRawRasterBand>\n', sep =  , file = f)
                cat('\t\t<Description>', names(x), '</Description>\n', sep = , file = f)
                cat('\t\t<SourceFilename relativetoVRT=1>', basename(fn), '</SourceFilename>\n', sep = , file = f)
                cat('\t\t<ImageOffset>', imgoff[i], '</ImageOffset>\n', sep = , file = f)
                cat('\t\t<PixelOffset>', pixoff, '</PixelOffset>\n', sep = , file = f)
                cat('\t\t<LineOffset>', lineoff, '</LineOffset>\n', sep = , file = f)
                cat('\t\t<ByteOrder>', byteorder, '</ByteOrder>\n', sep = , file = f)
                cat('\t\t<NoDataValue>', x@file@nodatavalue, '</NoDataValue>\n', sep = , file = f)
                cat('\t\t<Offset>', x@data@offset, '</Offset>\n', sep = , file = f)
                cat('\t\t<Scale>', x@data@gain, '</Scale>\n', sep = , file = f)
                cat('\t</VRTRasterBand>\n', sep = , file = f)
        }
        cat('</VRTDataset>\n', sep = , file = f)
        close(f)
        return( invisible(TRUE) )
}

124 hdrWorldFile.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : October 2008
# Version 0.9
# Licence GPL v3
.worldFile <- function(raster, extension=.wld) {
        hdrfile <- filename(raster)
        extension(hdrfile) <- extension
        thefile <- file(hdrfile, w)  
        cat(as.character(xres(raster)), \n, file = thefile)
        cat(0\n, file = thefile)
        cat(0\n, file = thefile)
        cat(-1 * yres(raster), \n, file = thefile)
    cat(xmin(raster) + 0.5 * xres(raster), \n, file = thefile) 
    cat(ymax(raster) - 0.5 * yres(raster), \n, file = thefile) 
        close(thefile)  
}

125 head.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : December 2010
# Version 0.9
# Licence GPL v3

if (!isGeneric(head)) {
        setGeneric(head, function(x, ...)
                standardGeneric(head))
}       
if (!isGeneric(tail)) {
        setGeneric(tail, function(x, ...)
                standardGeneric(tail))
}       
setMethod('head', signature(x='RasterLayer'), 
        function(x, cols=20, rows=10, ...) {
                nr <- min(x@nrows, max(1, rows))
                nc <- min(x@ncols, max(1, cols))
                v <- getValuesBlock(x, 1, nrows=nr, ncols=nc, format='matrix')
                return(v)
        }
)
setMethod('tail', signature(x='RasterLayer'), 
        function(x, cols=20, rows=10, ...) {
                nr <- min(x@nrows, max(1, rows))
                nc <- min(x@ncols, max(1, cols))
                sr <- x@nrows - nr + 1
                sc <- x@ncols - nc + 1
                v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc, format='matrix')
                return(v)
        }
)
setMethod('head', signature(x='RasterStackBrick'), 
        function(x, cols=10, rows=2, layers=10, ...) {
                nr <- min(x@nrows, max(1, rows))
                nc <- min(x@ncols, max(1, cols))
                nl <- min(nlayers(x), max(1, layers))
                v <- getValuesBlock(x, 1, nrows=nr, ncols=nc)
                return(v)
        }
)
setMethod('tail', signature(x='RasterStackBrick'), 
        function(x, cols=10, rows=2, layers=10, ...) {
                nr <- min(x@nrows, max(1, rows))
                nc <- min(x@ncols, max(1, cols))
                nl <- min(nlayers(x), max(1, layers))
                sr <- x@nrows - nr + 1
                sc <- x@ncols - nc + 1
                v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc)
                return(v)
        }
)
setMethod('head', signature(x='Spatial'), 
        function(x, n=6L,...) {
                if (.hasSlot(x, 'data')) {
                        head(x@data, n=n, ...)
                } else {
                        x[1,]
                }
        }
)
setMethod('tail', signature(x='Spatial'), 
        function(x,  n=6L, ...) {
                if (.hasSlot(x, 'data')) {
                        tail(x@data, n=n, ...)
                } else {
                        x[length(x),]
                }
        }
)

126 hillShade.R

# Author: Andrew Bevan, Oscar Perpiñán Lamigueiro, and Robert J. Hijmans
# Date : March 2010
# Version 1.0
# Licence GPL v3
hillShade <- function(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) {
        compareRaster(slope, aspect)
        direction <- direction * pi/180
        zenith <- (90 - angle)*pi/180

        #x <- cos(slope) * cos(declination) + sin(slope) * sin(declination) * cos(direction-aspect)
        if (normalize) {
                fun <- function(slp, asp) { 
                        shade <- cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) 
                        shade[shade < 0] <- 0
                        shade * 255
                }
        } else {
                fun <- function(slp, asp) { cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) }
        }
        x <- overlay(slope, aspect, fun=fun, filename=filename, ...)            
        return(x)
}

127 hist.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 1.0
# Licence GPL v3
setMethod('hist', signature(x='Raster'), 
        function(x, layer, maxpixels=100000, plot=TRUE, main, ...) {

                if (missing(layer)) {
                        y <- 1:nlayers(x)
                } else if (is.character(layer)) {
                        y <- match(layer, names(x))
                } else { 
                        y <- layer 
                }

                y <- unique(as.integer(round(y)))
                y <- na.omit(y)
                y <- y[ y >= 1 & y <= nlayers(x) ]
                nl <- length(y)

                if (nl == 0) {
                        stop('no layers selected')
                }
                if (missing(main)) {
                        main=names(x) 
                }

                if (nl > 1)     {
                        res <- list()
                        if (nl > 16) {
                                warning('only the first 16 layers are plotted')
                                nl <- 16
                                y <- y[1:16]
                        }
                        nc <- ceiling(sqrt(nl))
                        nr <- ceiling(nl / nc)
                        mfrow <- par(mfrow)
                        spots <- mfrow[1] * mfrow[2]
                        if (spots < nl) {
                                par(mfrow=c(nr, nc))
                        }
                        for (i in 1:length(y)) {
                                res[[i]] = .hist1(raster(x, y[i]), maxpixels=maxpixels, main=main[y[i]], plot=plot, ...) 
                        }               
                } else if (nl==1) {
                        if (nlayers(x) > 1) {
                                x <- x[[y]]
                                main <- main[y]
                        }
                        res <- .hist1(x, maxpixels=maxpixels, main=main, plot=plot, ...)        
                }               
                if (plot) {
                        return(invisible(res))
                } else {
                        return(res)
                }
        }
)
.hist1 <- function(x, maxpixels, main, plot, ...){
                if ( inMemory(x) ) {
                        v <- getValues(x)
                } else if ( fromDisk(x) ) {

                        if (ncell(x) <= maxpixels) {
                                v <- na.omit(getValues(x))
                        } else {
                        # TO DO: make a function that does this by block and combines  all data into a single histogram
                                v <- sampleRandom(x, maxpixels)
                                msg <- paste(round(100 * maxpixels / ncell(x)), % of the raster cells were used, sep=)
                                if (maxpixels > length(v)) {
                                        msg <- paste(msg,  (of which , 100 - round(100 * length(v) / maxpixels ), % were NA), sep=)
                                }
                                warning( paste(msg, . ,length(v), values used., sep=) )
                        }       
                } else { 
                        stop('cannot make a histogram; need data on disk or in memory')
                }       

                if (.shortDataType(x) == 'LOG') {
                        v <- v * 1
                }

                if (plot) {
                        hist(v, main=main, plot=plot, ...)  
                } else {
                        hist(v, plot=plot, ...)                 
                }
}

128 idwValue.R

# Author: Robert J. Hijmans
# Date :  November 2009
# Version 1.0
# Licence GPL v3
# under development
..idwValue <- function(raster, xy, ngb=4, pow=1, layer, n) {
        r <- raster(raster)
        longlat <- couldBeLonLat(r)
        cells <- cellFromXY(r, xy)
        adj <- adjacent(r, cells, ngb, pairs=TRUE, include=TRUE, id=TRUE)
        uc <- unique(adj[,3])
        row1 <- rowFromCell(r, min(uc, na.rm=TRUE))
        nrows <- row1 - 1 + rowFromCell(r, max(uc, na.rm=TRUE))
        offs <- cellFromRowCol(r, row1, 1) - 1
        cs <- uc - offs
        nl <- nlayers(raster)
        if (nl==1) {
                v <- cbind(uc, v=getValues(raster, row1, nrows)[cs])
        } else {
                v <- cbind(uc, v=getValues(raster, row1, nrows)[cs,])
        }
        m <- merge(adj, v, by.x='to', by.y=1)
        colnames(xy) <- c('x', 'y')
        m <- merge(m, cbind(1:nrow(xy), xy), by.x='id', by.y=1)

        pd <- pointDistance(m[,c('x', 'y')], xyFromCell(r, m$to), lonlat=longlat) / 1000
        pd <- pd^pow
        pd[pd==0] <- 1e-12

        if (nl==1) {
                pd[is.na(m$v)] <- NA
                as.vector( tapply(m$v*(1/pd), m$id, sum, na.rm=TRUE) / tapply(1/pd, m$id, sum, na.rm=TRUE) )
                #cbind(as.integer(names(res)), res)
        } else {
                lys <- 4:(4+nl-1)
                a1 <- aggregate(m[,lys]*(1/pd), list(m$id), sum) 
                a2 <- aggregate(1/pd, list(m$id), sum)
                res <- as.matrix(a1[,-1]) / as.vector(as.matrix(a2[,-1]))
                res <- cbind(as.vector(a1[,1]), res)
                res[, -1]
        }
}
#a=raster(nc=10,nr=10)
#xmin(a)=55
#projection(a) = +proj=utm +zone=33
#a[] = 1:ncell(a)
#a[50:75]=NA
#r = disaggregate(raster(a), 3)
#r[] = .idwValue(a, coordinates(r))
#plot(r)

129 imageplot2.R

# The functions is based on a function in the fields package
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
#
# Adjustments by Robert Hijmans
# July 2011
.asRaster <- function(x, col, breaks=NULL, r=NULL, colNA=NA) {
        if (!is.null(breaks)) {
                if (is.logical(x)) {
                        x <- x * 1
                }
                x[] <- as.numeric(cut(as.vector(x), breaks, include.lowest=TRUE))

        } else {
                #if (is.function(fun)) {
                #       x[] <- fun(x)
                #}
                if (is.null(r)) {
                        r <- range(x, na.rm=TRUE)
                }
                if (r[1] == r[2]) {
                        r[1] <- r[1] - 0.001
                        r[2] <- r[2] + 0.001
                }
                x <- (x - r[1])/ (r[2] - r[1])
                x <- round(x * (length(col)-1) + 1)
        }
        x[] <- col[x]
        if (!is.na(colNA)) {
                x[is.na(x)] <- rgb(t(col2rgb(colNA)), maxColorValue=255)
        }
        as.raster(x)
}

.rasterImagePlot <- function(x, col, add=FALSE, legend=TRUE, horizontal = FALSE, 
    legend.shrink=0.5, legend.width=0.6, legend.mar = ifelse(horizontal, 3.1, 5.1),
        legend.lab=NULL, graphics.reset=FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, 
    lab.breaks=NULL, axis.args=NULL, legend.args = NULL, interpolate=FALSE, box=TRUE, breaks=NULL, 
        zlim=NULL, zlimcol=NULL, fun=NULL, asp, colNA = NA, ...) {
        ffun <- NULL
        if (is.character(fun)) {
                if (fun %in% c('sqrt', 'log')) {
                        if (fun == 'sqrt') {
                                ffun <- fun
                                fun <- sqrt
                        } else {
                                ffun <- fun
                                fun <- log
                        }
                } else {
                        fun - NULL
                }
        } else {
                fun <- NULL
        }


        if (missing(asp)) {
                if (couldBeLonLat(x, warnings=FALSE)) {
                        ym <- mean(c(x@extent@ymax, x@extent@ymin))
                        asp <- 1/cos((ym * pi)/180)
                } else {
                        asp <- 1
                }               
        }

        e <- as.vector(t(bbox(extent(x))))
        x <- as.matrix(x)
        if (!is.null(fun)) {
                x <- fun(x)
        }
        x[is.infinite(x)] <- NA
        if (!is.null(zlim)) {
                if (!is.null(zlimcol)) {
                        x[x < zlim[1]] <- zlim[1]
                        x[x > zlim[2]] <- zlim[2]
                } else { #if (is.na(zlimcol)) {
                        x[x < zlim[1] | x > zlim[2]] <- NA
                } 
        }

        w <- getOption('warn')
        options('warn'=-1) 
        if (is.null(breaks)) {
                zrange <- range(x, zlim, na.rm=TRUE)
        } else {
                zrange <- range(x, zlim, breaks, na.rm=TRUE)
        }
        options('warn'=w) 
        if (! is.finite(zrange[1])) {
                legend <- FALSE 
        } else {
                x <- .asRaster(x, col, breaks, zrange, colNA)
        }

    old.par <- par(no.readonly = TRUE)
    if (add) {
        big.plot <- old.par$plt
    }
    if (legend.only) {
        graphics.reset <- TRUE
    }

    if (is.null(legend.mar)) {
        legend.mar <- ifelse(horizontal, 3.1, 5.1)
    }
    temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, 
                                                                        horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)

    smallplot <- temp$smallplot
    bigplot <- temp$bigplot
    if (legend.only) {
                box <- FALSE
        } else {
        if (!add) {
            par(plt = bigplot)
                        plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = n, , xaxs ='i', yaxs = 'i', asp=asp, ...)
        }
                rasterImage(x, e[1], e[3], e[2], e[4], interpolate=interpolate)
        big.par <- par(no.readonly = TRUE)
    } 

        if (legend) {
                if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
                        par(old.par)
                        stop(plot region is too small. Cannot add a legend\n)
                }
                ix <- 1
                minz <- zrange[1]
                maxz <- zrange[2]
                if (minz == maxz) {
                        if (!is.null(breaks)) {
                                breaks=minz
                        } else {
                                minz <- minz - 0.001
                                maxz <- maxz + 0.001
                        }
                }
                par(new=TRUE, pty = m, plt=smallplot, err = -1)

                if (!is.null(breaks)) {
                        binwidth <- (maxz - minz)/100
                        midpoints <- seq(minz, maxz, by = binwidth)
                        axis.args <- c(list(side=ifelse(horizontal,1,4), mgp=c(3,1,0), las=ifelse(horizontal,0,2)), axis.args)
                        if (is.null(axis.args$at)) {
                                axis.args$at <- breaks
                        }
                        if (is.null(axis.args$labels) ) {
                                axis.args$labels=lab.breaks
                        }

                } else {
                        axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args)
                }

                if (!horizontal) {
                        plot(NA, NA, xlim=c(0, 1), ylim=c(minz, maxz), type=n, xlab=, ylab=, xaxs ='i', yaxs = 'i', axes=FALSE)

                        if (is.null(breaks)) {
                                mult <- round(max(1, 100 / length(col) ))
                                xx <- .asRaster( ((mult*length(col)):1)/mult, col, colNA=colNA) 
                        } else {
                                xx <- rev(.asRaster(midpoints, col, breaks=breaks, colNA=colNA))
                        }
                        rasterImage(xx, 0, minz, 1, maxz, interpolate=FALSE)
                        if (!is.null(ffun)) {
                                at <- axTicks(2)
                                axis.args$at <- at
                                if (ffun=='sqrt') {
                                        at <- at^2
                                        if (max(at) > 5) {
                                                at <- round(at, 0)
                                        } else {
                                                at <- round(at, 1)
                                        }
                                        at <- unique(at)
                                        axis.args$at <- sqrt(at)
                                } else {
                                        at <- exp(at)
                                        if (max(at) > 5) {
                                                at <- round(at, 0)
                                        } else {
                                                at <- round(at, 1)
                                        }
                                        at <- unique(at)
                                        axis.args$at <- log(at)
                                }
                                axis.args$labels <- at
                        }
                        do.call(axis, axis.args)
                        box()
                } else {
                        plot(NA, NA, ylim=c(0, 1), xlim=c(minz, maxz), type=n, xlab=, ylab=, xaxs ='i', yaxs = 'i', axes=FALSE)

                        if (is.null(breaks)) {
                                mult <- round(max(1, 100 / length(col) ))
                                xx <- t(.asRaster((1:(mult*length(col)))/mult, col, colNA=colNA ))
                        } else {
                                xx <- t(.asRaster(midpoints, col, breaks=breaks, colNA=colNA))
                        }
                        rasterImage(xx, minz, 0, maxz, 1, interpolate=FALSE)
                        do.call(axis, axis.args)
                        box()
                }

                if (!is.null(legend.lab)) {
                        legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2)
                }
                if (!is.null(legend.args)) {
                        do.call(mtext, legend.args)
                }
        }

        mfg.save <- par()$mfg
        if (graphics.reset | add) {
                par(old.par)
                par(mfg = mfg.save, new = FALSE)
        } else {
                par(big.par)
                par(plt = big.par$plt, xpd = FALSE)
                par(mfg = mfg.save, new = FALSE)
        }
        if (!add & box ) box()
        invisible()

}

130 imageplot.R

# The functions below here were taken from the fields package !!! (image.plot and subroutines)
# to be adjusted for the RasterLayer object.
# fields, Tools for spatial data
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
.imageplot <- function (x, y, z, add=FALSE, legend=TRUE, nlevel = 64, horizontal = FALSE, 
# fields, Tools for spatial data
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
    legend.shrink = 0.5, legend.width = 0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, graphics.reset = FALSE, 
    bigplot = NULL, smallplot = NULL, legend.only = FALSE, col = heat.colors(nlevel), 
    lab.breaks = NULL, axis.args = NULL, legend.args = NULL, midpoint = FALSE, box=TRUE, useRaster=FALSE, ...) {
        zlim <- range(z, na.rm = TRUE)
    old.par <- par(no.readonly = TRUE)
    if (add) {
        big.plot <- old.par$plt
    }
    if (legend.only) {
        graphics.reset <- TRUE
    }
    if (is.null(legend.mar)) {
        legend.mar <- ifelse(horizontal, 3.1, 5.1)
    }

    temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, 
                                                                        horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)

    smallplot <- temp$smallplot
    bigplot <- temp$bigplot

    if (!legend.only) {
        if (!add) {
            par(plt = bigplot)
        }
                if (R.Version()$minor >= 13) {
                        image(x, y, z, add = add, col = col, useRaster=useRaster, ...)
                } else {
                        image(x, y, z, add = add, col = col, ...)
                }
        big.par <- par(no.readonly = TRUE)
    } else {
                box <- FALSE
        }

        if (legend) {
                if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
                        par(old.par)
                        stop(plot region too small to add legend\n)
                }
                ix <- 1
                minz <- zlim[1]
                maxz <- zlim[2]
                binwidth <- (maxz - minz)/nlevel
                midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth)
                iy <- midpoints
                iz <- matrix(iy, nrow = 1, ncol = length(iy))
                breaks <- list(...)$breaks
                par(new=TRUE, pty = m, plt=smallplot, err = -1)
                if (!is.null(breaks)) {
                        if (is.null(lab.breaks)) {
                                lab.breaks <- as.character(breaks)
                        }
                        axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), 
                                at = breaks, labels = lab.breaks), axis.args)
                } else {
                        axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args)
                }
                if (!horizontal) {
                        if (is.null(breaks)) {
                                if (R.Version()$minor >= 13) {
                                        image(ix, iy, iz, xaxt=n, yaxt=n, xlab=, ylab=, col=col, useRaster=useRaster)
                                } else {
                                        image(ix, iy, iz, xaxt=n, yaxt=n, xlab=, ylab=, col=col)                                
                                }
                        } else {
                                if (R.Version()$minor >= 13) {
                                        image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col=col, breaks=breaks, useRaster=useRaster)
                                } else {
                                        image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col=col, breaks=breaks)                             
                                }
                        }
                } else {
                        if (is.null(breaks)) {
                                if (R.Version()$minor >= 13) {
                                        image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, useRaster=useRaster)
                                } else {
                                        image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col)                           
                                }
                        } else {
                                if (R.Version()$minor >= 13) {
                                        image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks, useRaster=useRaster)
                                } else {
                                        image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks)
                                }
                        }
                }
                do.call(axis, axis.args)
                box()

                if (!is.null(legend.lab)) {
                        legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2)
                }
                if (!is.null(legend.args)) {
                        do.call(mtext, legend.args)
                }
        }
        mfg.save <- par()$mfg
    if (graphics.reset | add) {
        par(old.par)
        par(mfg = mfg.save, new = FALSE)
    } else {
        par(big.par)
        par(plt = big.par$plt, xpd = FALSE)
        par(mfg = mfg.save, new = FALSE)
    }

        if (!add & box ) box()
    invisible()
}
.polyimage <- function (x, y, z, col = heat.colors(64), transparent.color = white, 
# fields, Tools for spatial data
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
    midpoint = FALSE, zlim = range(z, na.rm = TRUE), xlim = range(x),  ylim = range(y), add = FALSE, border = NA, ...) {
        polyimageregrid <- function (x) { 
                temp.addcol <- function(X) {
                        N <- ncol(X)
                        cbind(X[, 1] - (X[, 2] - X[, 1]), X, (X[, N] - X[, (N - 1)]) + X[, N])
                }
                M <- nrow(x)
                N <- ncol(x)
                x <- (x[, 1:(N - 1)] + x[, 2:N])/2
                x <- (x[1:(M - 1), ] + x[2:M, ])/2
                x <- t(temp.addcol(x))
                t(temp.addcol(x))
        }
    drapecolor <- function (z, col = heat.colors(64), zlim = NULL, transparent.color = white, midpoint = TRUE) {
                eps <- 1e-07
                if (is.null(zlim)) {
                        zlim <- range(c(z), na.rm = TRUE)
                }
                z[(z < zlim[1]) | (z > zlim[2])] <- NA
                NC <- length(col)
                M <- nrow(z)
                N <- ncol(z)
                if (midpoint) {
                        z <- (z[1:(M - 1), 1:(N - 1)] + z[2:M, 1:(N - 1)] + z[1:(M - 1), 2:N] + z[2:M, 2:N])/4
                }
                dz <- (zlim[2] * (1 + eps) - zlim[1])/NC
                zcol <- floor((z - zlim[1])/dz + 1)
                ifelse(zcol > NC, transparent.color, col[zcol])
        }

    Dx <- dim(x)
    Dy <- dim(y)
    if (any((Dx - Dy) != 0)) {
        stop( x and y matrices should have same dimensions)
    }
    Dz <- dim(z)
    if (all((Dx - Dz) == 0) & !midpoint) {
        x <- polyimageregrid(x)
        y <- polyimageregrid(y)
    }
    zcol <- drapecolor(z, col = col, midpoint = midpoint, zlim = zlim, 
        transparent.color = transparent.color)
    if (!add) {
        plot(xlim, ylim, type = n, ...)
    }
    N <- ncol(x)
    Nm1 <- N - 1
    M <- nrow(x)
    Mm1 <- M - 1
    for (i in (1:Mm1)) {
        xp <- cbind(x[i, 1:Nm1], x[i + 1, 1:Nm1], x[i + 1, 2:N], 
            x[i, 2:N], rep(NA, Nm1))
        yp <- cbind(y[i, 1:Nm1], y[i + 1, 1:Nm1], y[i + 1, 2:N], 
            y[i, 2:N], rep(NA, Nm1))
        xp <- c(t(xp))
        yp <- c(t(yp))
        polygon(xp, yp, border = NA, col = c(zcol[i, 1:Nm1]))
    }
}
.imageplotplt <- function (x, add = FALSE, legend.shrink = 0.9, legend.width = 1, 
# fields, Tools for spatial data
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
    horizontal = FALSE, legend.mar = NULL, bigplot = NULL, smallplot = NULL, ...) {
    old.par <- par(no.readonly = TRUE)
    if (is.null(smallplot)) 
        stick <- TRUE
    else stick <- FALSE
    if (is.null(legend.mar)) {
        legend.mar <- ifelse(horizontal, 3.1, 5.1)
    }
    char.size <- ifelse(horizontal, par()$cin[2]/par()$din[2], 
        par()$cin[1]/par()$din[1])
    offset <- char.size * ifelse(horizontal, par()$mar[1], par()$mar[4])
    legend.width <- char.size * legend.width
    legend.mar <- legend.mar * char.size
    if (is.null(smallplot)) {
        smallplot <- old.par$plt
        if (horizontal) {
            smallplot[3] <- legend.mar
            smallplot[4] <- legend.width + smallplot[3]
            pr <- (smallplot[2] - smallplot[1]) * ((1 - legend.shrink)/2)
            smallplot[1] <- smallplot[1] + pr
            smallplot[2] <- smallplot[2] - pr
        }
        else {
            smallplot[2] <- 1 - legend.mar
            smallplot[1] <- smallplot[2] - legend.width
            pr <- (smallplot[4] - smallplot[3]) * ((1 - legend.shrink)/2)
            smallplot[4] <- smallplot[4] - pr
            smallplot[3] <- smallplot[3] + pr
        }
    }
    if (is.null(bigplot)) {
        bigplot <- old.par$plt
        if (!horizontal) {
            bigplot[2] <- min(bigplot[2], smallplot[1] - offset)
        }
        else {
            bottom.space <- old.par$mar[1] * char.size
            bigplot[3] <- smallplot[4] + offset
        }
    }
    if (stick & (!horizontal)) {
        dp <- smallplot[2] - smallplot[1]
        smallplot[1] <- min(bigplot[2] + offset, smallplot[1])
        smallplot[2] <- smallplot[1] + dp
    }
    return(list(smallplot = smallplot, bigplot = bigplot))
}

131 image.R

# Author: Robert J. Hijmans
# Date :  April 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(image)) {
        setGeneric(image, function(x,...)
                standardGeneric(image))
}       
setMethod(image, signature(x='RasterLayer'), 
        function(x, maxpixels=500000, useRaster=TRUE, ...)  {
#               coltab <- x@legend@colortable
#               if (is.null(coltab) | length(coltab) == 0 | is.null(list(...)$col)) {
#                       colortab <- FALSE               
#               }
#               if (missing(main)) {    main <- names(x)        }
                x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE)
                y <- yFromRow(x, nrow(x):1)
                value <- t(as.matrix(x)[nrow(x):1,])
                x <- xFromCol(x,1:ncol(x))
#               if (colortab) {
#                       image(x=x, y=y, z=value, col=coltab[value], useRaster=useRaster, ...)
#               } else {
                image(x=x, y=y, z=value, useRaster=useRaster, ...)                      
#               }
        }
)
setMethod(image, signature(x='RasterStackBrick'), 
        function(x, y=1, maxpixels=100000, useRaster=TRUE, main, ...)  {
                y <- round(y)
                stopifnot(y > 0 & y <= nlayers(x))
                x <- raster(x, y)
                if (missing(main)) {
                        main <- names(x)
                }
                image(x, maxpixels=maxpixels, useRaster=useRaster, main=main, ...)
        }       
)

132 index.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  January 2009
# Version 0.9
# Licence GPL v3
setMethod([, c(Raster, Spatial, missing),
function(x, i, j, ... ,drop=TRUE) {
        if (inherits(i, 'SpatialPoints')) {
                i <- coordinates(i)
                i <- cellFromXY(x, i)
                .doExtract(x, i, ..., drop=drop)

        } else {
                if (drop) {
                        extract(x, i, ...)
                } else {
                        x <- crop(x, i, ...)
                        rasterize(i, x, mask=TRUE, ...)
                }
        }
})
setMethod([, c(Raster, RasterLayer, missing),
function(x, i, j, ... ,drop=TRUE) {

        if (! hasValues(i) ) {
                i <- extent(i)
                callNextMethod(x, i=i, ..., drop=drop)

        } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) {
                i <- which( as.logical( getValues(i) ) )
                .doExtract(x, i, drop=drop)
        } else {
                i <- intersect(extent(x), extent(i))
                callNextMethod(x, i=i, ..., drop=drop)
        }
})
setMethod([, c(Raster, Extent, missing),
function(x, i, j, ... ,drop=TRUE) {
        if (drop) {
                return( extract(x, i) )
        } else {
                return( crop(x, i) )
        }
} )     

setMethod([, c(Raster, missing, missing),
function(x, i, j, ... ,drop=TRUE) {
        if (drop) {
                return(getValues(x))
        } else {
                return(x)
        }
})
setMethod([, c(Raster, numeric, numeric),
function(x, i, j, ... ,drop=TRUE) {
                i <- cellFromRowColCombine(x, i, j)
                .doExtract(x, i, drop=drop)
        }
)
setMethod([, c(Raster, missing, numeric),
function(x, i, j, ... ,drop=TRUE) {
        j <- cellFromCol(x, j)
        .doExtract(x, j, drop=drop)
})
setMethod([, c(Raster, numeric, missing),
function(x, i, j, ... ,drop=TRUE) {
        theCall <- sys.call(-1)
        narg <- length(theCall) - length(match.call(call=sys.call(-1)))
        if (narg > 0) {
                i <- cellFromRow(x, i)
        } 
        .doExtract(x, i, drop=drop)
})
setMethod([, c(Raster, matrix, missing),
function(x, i, j, ... ,drop=TRUE) {
        if (ncol(i) == 2) {
                i <- cellFromRowCol(x, i[,1], i[,2])
        } else {
                i <- as.vector(i)
        }
        .doExtract(x, i, drop=drop)
})
setMethod([, c(Raster, logical, missing),
function(x, i, j, ... , drop=TRUE) {
        theCall <- sys.call(-1)
        narg <- length(theCall) - length(match.call(call=sys.call(-1)))
        if (narg > 0) {
                stop('logical indices are only accepted if only the first index is used')
        }
        i <- which(i)
        .doExtract(x, i, drop=drop)
})
.doExtract <- function(x, i, drop) {    
        if (! hasValues(x) ) {
                stop('no data associated with this Raster object')
        }
        if (length(i) < 1) return(NULL) 

        nacount <- sum(is.na(i))
        if (nacount > 0) {
                warning('some indices are invalid (NA returned)')
        }       
        if (drop) {
                return( .cellValues(x, i) )

        } else {
                i <- na.omit(i)
                r <- rasterFromCells(x, i, values=FALSE)
                newi <- cellFromXY(r, xyFromCell(x, i))
                if (nlayers(x) > 1) {
                        r <- brick(r)
                        v <- matrix(NA, nrow=ncell(r), ncol=nlayers(x))
                        v[newi,] <- .cellValues(x, i)
                        v <- setValues(r, v)
                        return(v)
                } else {
                        r[newi] <- .cellValues(x, i)
                        return(r)
                }
        }
}

133 indexReplaceBrick.R

# Author: Robert J. Hijmans
# Date :  January 2009
# Version 1.0
# Licence GPL v3
setMethod($, Raster,  function(x, name) { x[[name]] } )
setMethod($<-, Raster,  
        function(x, name, value) { 
                i <- which(name == names(x))[1]
                if (is.na(i)) {
                        if (inherits(value, 'Raster')) {
                                names(value) <- name
                                x <- addLayer(x, value)
                                return(x)
                        } else {
                                r <- raster(x)
                                names(r) <- name
                                r[] <- value
                                x <- addLayer(x, r)
                                return(x)
                        }
                } else {
                        if (inherits(value, 'Raster')) {
                                x[[name]] <- value
                        } else {
                                r <- x[[name]]
                                r[] <- value
                                x[[name]] <- value
                        }
                        return(x)
                } 
        }
)
setMethod([[, Raster,
function(x,i,j,...,drop=TRUE) {
        if ( missing(i)) { 
                stop('you must provide an index') 
        }
        if (! missing(j)) { 
                warning('second index is ignored') 
        }
        if (is.numeric(i)) {
                sgn <- sign(i)
                sgn[sgn==0] <- 1
                if (! all(sgn == 1) ) {
                        if (! all(sgn == -1) ) {
                                stop(only 0's may be mixed with negative subscripts)
                        } else {
                                i <- (1:nlayers(x))[i]
                        }
                }
        }
        subset(x, i, drop=drop)
})
setReplaceMethod([[, c(RasterStackBrick, character, missing),
        function(x, i, j, value) {
                n <- which(i == names(x))[1]
                if (is.na(n)) {
                        n <- nlayers(x) + 1
                } 
                if (inherits(value, 'Raster')) {
                        names(value) <- i
                }
                x[[n]] <- value
                x
        }
)
setReplaceMethod([[, c(RasterStack, numeric, missing),
        function(x, i, j, value) {

                i <- round(i)
                if (i < 1) {
                        stop('index should be > 0')
                }
                nl <- nlayers(x)
                if (i > nl + 1) {
                        stop('index should be <= nlayers(x)+1')
                }
                if (!inherits(value, 'RasterLayer')) {
                        val <- value
                        if (i > nl) {
                                value <- x[[nl]]
                        } else {
                                value <- x[[i]]
                        }
                        value[] <- val
                } else {
                        compareRaster(x, value)
                }

                if (i > nl) {
                        x <- addLayer(x, value)
                } else {
                        x@layers[[i]] <- value
                }
                x
        }
)
setReplaceMethod([[, c(RasterBrick, numeric, missing),
        function(x, i, j, value) {
                i <- round(i)
                if (i < 1) {
                        stop('index should be > 0')
                }
                nl <- nlayers(x)
                if (i > nl + 1) {
                        stop('index should be <= nlayers(x)+1')
                }

                if (canProcessInMemory(x)) {
                        if (!inMemory(x)) {
                                x <- readAll(x)
                        }
                        if (inherits(value, 'RasterLayer')) {
                                compareRaster(x, value)
                                x <- setValues(x, getValues(value), i)
                                names(x)[i] <- names(value)
                        } else {
                                val <- value
                                if (i > nl) {
                                        value <- getValues(x[[nl]])
                                } else {
                                        value <- getValues(x[[i]])
                                }
                                # for recycling
                                value[] <- val
                                x <- setValues(x, value, i)
                        }
                } else {
                        x <- stack(x)
                        x[[i]] <- value
                }       
                return(x)
        }
)
setReplaceMethod([, c(RasterStackBrick, Raster, missing),
        function(x, i, j, value) {

                nl <- nlayers(i)
                if (! hasValues(i) ) {
                        i <- cellsFromExtent(x, i)
                } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) {
                        dims <- dim(i)
                        i <- as.logical(getValues(i))
                        dim(i) <- c(prod(dims[1:2]), dims[3])
                } else {
                        i <- cellsFromExtent(x, i)
                }                       
                if (nl < nlayers(x)) {
                        .replace(x, i, value=value, recycle=nl)
                } else {
                        .replace(x, i, value=value, recycle=1) 
                }
        }
)
setReplaceMethod([, c(Raster, Extent, missing),
        function(x, i, j, value) {
                i <- cellsFromExtent(x, i)
                .replace(x, i, value=value, recycle=1)
        }
)
setReplaceMethod([, c(Raster, Spatial, missing),
        function(x, i, j, value) {
                if (inherits(i, 'SpatialPolygons')) {
                        v <- 1:length(i@polygons)
                        v[] <- value
                        return( .polygonsToRaster(i, x, value=v, fun='last', mask=FALSE, update=TRUE, updateValue=all, silent=TRUE) )

                } else if (inherits(i, 'SpatialLines')) {
                        v <- 1:length(i@lines)
                        v[] <- value
                        return( .linesToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue=all, silent=TRUE) )

                } else { # if (inherits(i, 'SpatialPoints')) {
                        i <- cellsFromXY(x, coordinates(i))
                        return( .replace(x, i, value=value, recycle=1) )
                }
        }
)
setReplaceMethod([, c(RasterStackBrick,missing,missing),
        function(x, i, j, value) {

                nl <- nlayers(x)
                if (inherits(x, 'RasterStack')) {
                        x <- brick(x, values=FALSE)
                }

                if (is.matrix(value)) {
                        if (all(dim(value) == c(ncell(x), nl))) {
                                x <- try( setValues(x, value))
                        } else {
                                stop('dimensions of the matrix do not match the Raster* object')
                        }

                } else {
                        v <- try( matrix(nrow=ncell(x), ncol=nl) )
                        if (class(x) != 'try-error') {
                                v[] <- value
                                x <- try( setValues(x, v) )
                        }
                }
                if (class(x) == 'try-error') {
                        stop('cannot set values on this raster (it is too large)')
                }
                return(x)

        }
)
setReplaceMethod([, c(Raster, numeric, numeric),
        function(x, i, j, value) {
                i <- cellFromRowColCombine(x, i, j)
                .replace(x, i, value, recycle=1)
        }
)       
setReplaceMethod([, c(Raster,missing, numeric),
        function(x, i, j, value) {
                j <- cellFromCol(x, j)
                .replace(x, j, value=value, recycle=1)
        }
)
setReplaceMethod([, c(Raster,numeric, missing),
        function(x, i, j, value) {
                theCall <- sys.call(-1)
                narg <- length(theCall)-length(match.call(call=sys.call(-1)))
                if (narg > 0) {
                        i <- cellFromRow(x, i)
                }
                .replace(x, i=i, value=value, recycle=1)
        }
)
setReplaceMethod([, c(Raster, matrix, missing),
        function(x, i, j, value) {
                if (ncol(i) == 2) {
                        i <- cellFromRowCol(x, i[,1], i[,2])
                } else {
                        i <- as.vector(i)
                }
                .replace(x, i=i, value=value, recycle=1)
        }
)
setReplaceMethod([, c(Raster, logical, missing),
        function(x, i, j, value) {
                .replace(x, i, value, recycle=1)
        }
)

134 indexReplace.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  January 2009
# Version 1.0
# Licence GPL v3
setReplaceMethod([, c(RasterLayer, RasterLayer, missing),
        function(x, i, j, value) {
                if (! hasValues(i) ) {
                        i <- cellsFromExtent(x, i)

                } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) {
                        i <- as.logical( getValues(i) )

                } else {
                        i <- cellsFromExtent(x, i)
                }               

                .replace(x, i, value=value, recycle=1) 
        }
)
setReplaceMethod([, c(RasterLayer,missing,missing),
        function(x, i, j, value) {

                if (length(value) == ncell(x)) {
                        x <- try( setValues(x, value))
                } else if (length(value) == 1) {
                        x <- try( setValues(x, rep(value, times=ncell(x))) )
                } else {
                        v <- try( vector(length=ncell(x)) )
                        if (class(x) != 'try-error') {
                                v[] <- value
                                x <- try( setValues(x, v) )
                        }
                }
                if (class(x) == 'try-error') {
                        stop('cannot replace values on this raster (it is too large')
                }
                return(x)

        }
)
.replace <- function(x, i, value, recycle=1) {

        if ( is.logical(i) ) {
                i <- which(i)
        } else {
        #       if (! is.numeric(i)) { 
        #               i <- as.integer(i) 
        #       }
                i <- na.omit(i)
        }
        nl <- nlayers(x)
  # recycling
        if (nl > 1) {
                rec2 <- ceiling(nl / recycle)
                if (rec2 > 1) {
                        add <- ncell(x)*recycle * (0:(rec2-1))
                        i <- as.vector(t((matrix(rep(i, rec2), nrow=rec2, byrow=TRUE)) + add))
                }
        }
        j <- i > 0 & i <= (ncell(x)*nl)

        if (!all(j)) {
                i <- i[j]
                if (length(value) > 1) {
                        value <- value[j]
                }
        }
        if ( inMemory(x) ) {
                if (inherits(x, 'RasterStack')) {
                        x <- brick( x, values=TRUE )
                        # this may go to disk, hence we check again below
                }       
        }

        if ( inMemory(x) ) {
                x@data@values[i] <- value
                x <- setMinMax(x)
                x <- .clearFile(x)
                return(x)

        } else if (canProcessInMemory(x)) {
                if (inherits(x, 'RasterStack')) {
                        x <- brick( x, values=TRUE )
                        if (!inMemory(x)) {
                                x <- readAll(x) 
                        }
                        x <- .clearFile(x)
                } else if ( fromDisk(x) ) {
                        x <- readAll(x)
                        x <- .clearFile(x)
                } else {
                        x <- setValues(x, rep(NA, times=ncell(x)))
                }
                x@data@values[i] <- value
                x <- setMinMax(x)
                return(x)

        } else {

                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='replace')
                hv <- hasValues(x)
                if (nl==1) {
                        if (! length(value) %in% c(1, length(i))) {
                                stop('cannot replace values in large Raster objects if their length is not 1 or the number of cells to be replaced')
                        }
                        r <- raster(x)
                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                        for (k in 1:tr$n) {
                                # cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x))
                                cell1 <- cellFromRowCol(x, tr$row[k], 1)
                                cell2 <- cell1 + tr$nrows[k] * ncol(x) - 1
                                if (hv) {
                                        v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k])
                                } else {
                                        v <- rep(NA, 1+cell2-cell1)
                                }
                                j <- which(i >= cell1 & i <= cell2)
                                if (length(j) > 0) {
                                        localcells <- i[j] - (cell1-1)
                                        if (length(value) == length(i)) {
                                                v[localcells] <- value[j]
                                        } else {
                                                v[localcells] <- value
                                        }
                                }
                                r <- writeValues(r, v, tr$row[k])
                                pbStep(pb, k)   
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)

                } else {
                        if (! length(value) %in% c(1, length(i))) {
                                stop('length of replacement values does not match the length of the index')
                        }
                        r <- brick(x, values=FALSE)
                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                        add <- (0:(nl-1)) * ncell(x)
                        for (k in 1:tr$n) {
                                cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x))
                                if (hv) {
                                        v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k])
                                } else {
                                        v <- matrix(NA, nrow=length(cells), ncol=nl)
                                }
                                cells <- cells + rep(add, each=length(cells))
                                j <- cells %in% i
                                if (sum(j) > 0) {
                                        v[j] <- value
                                }
                                r <- writeValues(r, v, tr$row[k])
                                pbStep(pb, k)
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)
                }       
        }
}

135 inifile.R

# Authors: Robert J. Hijmans 
# contact: r.hijmans@gmail.com
# Date : October 2008
# Version 0.9
# Licence GPL v3
.strSplitOnFirstToken <- function(s, token==) {
        pos <- which(strsplit(s, '')[[1]]==token)[1]
        if (is.na(pos)) {
                return(c(trim(s), NA)) 
        } else {
                first <- substr(s, 1, (pos-1))
                second <- substr(s, (pos+1), nchar(s))
                return(trim(c(first, second)))
        }
}
.strSplitOnLastToken <- function(s, token==) {
        # not used here
        pos <- unlist(strsplit(s, ''))
        pos <- max(which(pos==token))
        if (!is.finite(pos)) {
                return(c(s, NA)) 
        } else {
                first <- substr(s, 1, (pos-1))
                second <- substr(s, (pos+1), nchar(s))
                return(trim(c(first, second)))
        }
}

readIniFile <- function(filename, token='=', commenttoken=';', aslist=FALSE, case) {
    stopifnot(file.exists(filename))

        Lines <- trim(readLines(filename,  warn = FALSE))

        ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=commenttoken) } ) 
        Lines <- matrix(unlist(ini), ncol=2, byrow=TRUE)[,1]
        ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=token) }) 

        ini <- matrix(unlist(ini), ncol=2, byrow=TRUE)
        ini <- ini[ ini[,1] != , , drop=FALSE]
        ns <- length(which(is.na(ini[,2])))
        if (ns > 0) {
                sections <- c(which(is.na(ini[,2])), length(ini[,2]))
# here I should check whether the section text is enclosed in [ ]. If not, it is junk text that should be removed, rather than used as a section
                ini <- cbind(, ini)
                for (i in 1:(length(sections)-1)) {
                        ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2]
                }       
                ini[,1] <- gsub(\\[, , ini[,1])
                ini[,1] <- gsub(\\], , ini[,1])
                sections <- sections[1:(length(sections)-1)]
                ini <- ini[-sections,]
        } else {
                ini <- cbind(, ini)     
        }

        if (!missing(case)) {
                ini <- case(ini)
        }       

        colnames(ini) <- c(section, name, value)

        if (aslist) {
                iniToList <- function(ini) {
                        un <- unique(ini[,1])
                        LST <- list()
                        for (i in 1:length(un)) {
                                sel <- ini[ini[,1] == un[i], 2:3, drop=FALSE]
                                lst <- as.list(sel[,2])
                                names(lst) <- sel[,1]
                                LST[[i]] <- lst
                        }
                        names(LST) <- un
                        return(LST)
                }
                ini <- iniToList(ini)
        }

        return(ini)
}

136 init.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
init <- function(x, fun, v, filename=, ...) {
        if (missing(fun) & missing(v)) {
                stop('provide either a function fun or an option v')
        }
        if (missing(fun)) {
                v = tolower(v[1])
                stopifnot (v %in% c('x', 'y', 'row', 'col', 'cell'))
        }
        out <- raster(x)
        filename <- trim(filename)

        inmem=TRUE
        if (!canProcessInMemory(out, 2)) {
                inmem=FALSE
                if (filename == '') {
                        filename <- rasterTmpFile()                                                                     
                }
        }

        if (missing(fun)) {
                if ( inmem ) {
                        if (v == 'cell') { 
                                out <- setValues(out, 1:ncell(out)) 
                        } else if (v == 'row') { 
                                out <- setValues(out, rep(1:nrow(out), each=ncol(out)))
                        } else if (v == 'y') { 
                                out <- setValues(out, rep(yFromRow(out, 1:nrow(out)), each=ncol(out)))
                        } else if (v == 'col') { 
                                out <- setValues(out, rep(1:ncol(out), times=nrow(out)))
                        } else if (v == 'x') { 
                                out <- setValues(out, rep(xFromCol(out, 1:ncol(out)), times=nrow(out))) 
                        }
                } else {
                        out <- writeStart(out, filename=filename, ...)
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='init', ...)
                        for (i in 1:tr$n) {
                                if (v == 'cell') { 
                                        out <- writeValues(out, cellFromRowCol(out, tr$row[i],1):cellFromRowCol(out, tr$row[i]+tr$nrows[i]-1, ncol(out)), tr$row[i])
                                } else if (v == 'row') {
                                        r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1)
                                        out <-  writeValues(out, rep(r, each=ncol(out)), tr$row[i])
                                } else if (v == 'col') { 
                                        out <- writeValues(out, rep(1:ncol(out), tr$nrows[i]), tr$row[i])
                                } else if (v == 'x') { 
                                        out <- writeValues(out, rep(xFromCol(out, 1:ncol(out)), tr$nrows[i]), tr$row[i])
                                } else if (v == 'y') { 
                                        r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1)        
                                        out <- writeValues(out, rep(yFromRow(out, r), each=ncol(out)), tr$row[i])
                                }
                                pbStep(pb, i)
                        }
                        pbClose(pb)
                        out <- writeStop(out)
                }
        } else {
                if ( inmem ) {
                        n <- ncell(out)
                        out <- setValues(out, fun(n)) 
                } else {
                        out <- writeStart(out, filename=filename, ...)
                        tr <- blockSize(out)
                        pb <- pbCreate(tr$n, label='init', ...)
                        for (i in 1:tr$n) {
                                n <- ncol(out) * tr$nrows[i]
                                out <- writeValues(out, fun(n), tr$row[i])
                                pbStep(pb, r)
                        }
                        pbClose(pb)
                        out <- writeStop(out)
                }
        }
        if (inmem & filename != '') {
                out <- writeRaster(out, filename=filename, ...)
        }
        return(out)
}

137 intDataType.R

# raster package
# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  November 2009
# Version 0.9
# Licence GPL v3
.checkIntDataType <- function(mn, mx, dtype) {
        mn <- round(mn)
        mx <- round(mx)
        ok <- TRUE
        if (dtype == 'INT') {
                return(.getIntDataType(mn, mx) )
        } else if (dtype == 'INT1S') {
                if (mn < -127 | mx > 128) {
                        ok <- FALSE
                }
        } else if (dtype == 'INT1U') {
                if (mn < 0 | mx > 256) {
                        ok <- FALSE             
                }
        } else  if (dtype == 'INT2S') {
                if (mn < -32767 | mx > 32768) {
                        ok <- FALSE                     
                }
        } else  if (dtype == 'INT2U') {
                if (mn <= 0 | mx > 65534 ) {
                        ok <- FALSE
                }
        } else if (dtype == 'INT4S') {
                if (mn < -2147483647 | mx > 2147483648 ) {
                        ok <- FALSE
                }
        } else if (dtype == 'INT4U') {
                if (mn < 0 | mx > 2^32 ) {
                        ok <- FALSE
                }
#       } else if (dtype == 'INT8S') {
#               if (mn < -2^63/2 | mx > 2^64/2) {
#                       ok <- FALSE
#               }
        } else {
                stop('unknown integer type:', dtype)
        }
        if (!ok) { 
                dtype <- .getIntDataType(mn, mx)
                warning('changed INT data type to: ', dtype)
        }       
        return(dtype)
}
.getIntDataType <- function(mn, mx) {
# optimize the number of bytes within the datatype
        if (mn > -128 & mx < 128) {
                datatype <- 'INT1S'
        } else if (mn >=0 & mx < 256) {
                datatype <- 'INT1U'
        } else if (mn > -32767 & mx < 32768) {
                datatype <- 'INT2S'
        } else if (mn >= 0 & mx < 65534 ) {
                datatype <- 'INT2U'
        } else if (mn > -2147483647 & mx < 2147483648 ) {
                datatype <- 'INT4S'
        } else if (mn > 0 & mx < 2^32 ) {
                datatype <- 'INT4U'
##      } else if (mn > -(2^63/2) & mx < (2^64/2)) {
#               datatype <- 'INT8S'
        } else {
                stop('these values are too large to be saved as integers')
        }
        return(datatype)
}
..intSetNA <- function(v, dtype) {
        if (dtype == 'INT1S') {
                v[v < -127 | v > 128] <- NA
        } else if (dtype == 'INT1U') {
                v[v <=0 | v > 256] <- NA
        } else  if (dtype == 'INT2S') {
                v[v < -32767 | v > 32768] <- NA
        } else  if (dtype == 'INT2U') {
                v[v <= 0 | v > 65534] <- NA
        } else if (dtype == 'INT4S') {
                v[v < -2147483647 | v > 2147483648] <- NA
        } else if (dtype == 'INT8S') {
                v[v < -2^63/2 | v > 2^64/2] <- NA
        } 
        return(v)
}

138 interpolate.R

if (!isGeneric(interpolate)) {
        setGeneric(interpolate, function(object, ...)
                standardGeneric(interpolate))
}       
# to do: should allow index to be a vector
setMethod('interpolate', signature(object='Raster'), 

        function(object, model, filename=, fun=predict, xyOnly=TRUE, xyNames=c('x','y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) {

                predrast <- raster(object)
                filename <- trim(filename)
                ln <- NULL

                if (!is.null(ext)) {
                        predrast <- crop(predrast, extent(ext))
                        firstrow <- rowFromY(object, yFromRow(predrast, 1))
                        firstcol <- colFromX(object, xFromCol(predrast, 1))
                } else {
                        firstrow <- 1
                        firstcol <- 1
                }
                ncols <- ncol(predrast)

                lyrnames <- names(object)
                xylyrnames <- c('x', 'y', lyrnames)
                haveFactor <- FALSE
                dataclasses <- try( attr(model$terms, dataClasses)[-1], silent=TRUE)
                if (!is.null(dataclasses)) {
                        varnames <- names(dataclasses)
                        if (class(dataclasses) != 'try-error') {
                                if ( length( unique(lyrnames[(lyrnames %in% varnames)] )) != length(lyrnames[(lyrnames %in% varnames)] )) {
                                        stop('duplicate names in Raster* object: ', lyrnames)
                                }
                                f <- names( which(dataclasses == 'factor') )
                                if (length(f) > 0) { haveFactor <- TRUE } 
                        }
                }


                if (!canProcessInMemory(predrast) && filename == '') {
                        filename <- rasterTmpFile()     
                } 
                if (! xyOnly) {
                        if (inherits(object, 'RasterStack')) {
                                if (nlayers(object)==0) { 
                                        warning('object has no data, xyOnly set to TRUE')
                                        xyOnly <- TRUE 
                                }
                        } else {
                                if ( !  fromDisk(object) ) {
                                        if (! inMemory(object) ) {
                                                warning('object has no data, xyOnly set to TRUE')
                                                xyOnly <- TRUE 
                                        }
                                }                               
                        }
                }
                if (xyOnly) {
                        na.rm <- FALSE
                }

                if (inherits(model, gstat)) { 
                        gstatmod <- TRUE 
                        if (!is.null(model$locations) && inherits(model$locations, formula))  {
                                # should be ~x + y  ; need to check if it is ~lon + lat; or worse ~y+x
                                sp <- FALSE
                        } else {
                                sp <- TRUE
                        }
                } else { 
                        gstatmod <- FALSE 
                }

                tr <- blockSize(predrast, n=nlayers(object)+3)
                ablock <- 1:(ncol(predrast) * tr$nrows[1])
                napred <- rep(NA, ncol(predrast)*tr$nrows[1])

                pb <- pbCreate(tr$n, label='interpolate',  ... )                        

                if (filename == '') {
                        v <- matrix(NA, ncol=nrow(predrast), nrow=ncol(predrast))
                } else {
                        predrast <- writeStart(predrast, filename=filename, ... )
                }
                for (i in 1:tr$n) {
                        if (i==tr$n) { 
                                ablock <- 1:(ncol(predrast) * tr$nrows[i])
                                napred <- rep(NA, ncol(predrast) * tr$nrows[i])
                        }
                        rr <- firstrow + tr$row[i] - 1

                        if (xyOnly) {
                                p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) 
                                p <- na.omit(p)
                                blockvals <- data.frame(x=p[,1], y=p[,2])
                        } else {
                                blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols))
                                colnames(blockvals) <- lyrnames # necessary if there is only one layer
                                if (haveFactor) {
                                        for (i in 1:length(f)) {
                                                blockvals[,f[i]] <- as.factor(blockvals[,f[i]])
                                        }
                                }
                                p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) 
                                blockvals <- cbind(data.frame( x=p[,1], y=p[,2]), blockvals) 
                        } 
                        if (! is.null(const)) {
                                blockvals <- cbind(blockvals, const)
                        }

                        colnames(blockvals)[1:2] <- xyNames[1:2]

                        if (gstatmod) { 
                                if (sp) { 
                                        row.names(p) <- 1:nrow(p)
                                        blockvals <- SpatialPointsDataFrame(coords=p, data = blockvals, proj4string=projection(predrast, asText = FALSE))
                                }
                                if (i == 1) { 
                                        predv <- predict(model, blockvals, debug.level=debug.level, ...) 
                                        ln <- names(predv)[index]
                                } else { 
                                        predv <- predict(model, blockvals, debug.level=0, ...) 
                                }
                                if (sp) { 
                                        predv <- predv@data[,index] 
                                } else { 
                                        predv <- predv[,index+2] 
                                }

                        } else {  

                                if (na.rm) {  
                                        blockvals <- na.omit(blockvals)         
                                }
                                if (nrow(blockvals) == 0 ) {
                                        predv <- napred
                                } else {
                                        predv <- fun(model, blockvals, ...)     
                                }
                                if (class(predv)[1] == 'list') {
                                        predv = unlist(predv)
                                        if (length(predv) != nrow(blockvals)) {
                                                predv = matrix(predv, nrow=nrow(blockvals))
                                        }                                       
                                }
                                if (isTRUE(dim(predv)[2] > 1)) {
                                        predv = predv[,index]
                                }                                               
                                if (na.rm) {  
                                        naind <- as.vector(attr(blockvals, na.action))
                                        if (!is.null(naind)) {
                                                p <- napred
                                                p[-naind] <- predv
                                                predv <- p
                                                rm(p)
                                        }
                                }

                                # to change factor to numeric; should keep track of this to return a factor type RasterLayer
                                predv <- as.numeric(predv)

                        }

                        if (filename == '') {
                                predv = matrix(predv, nrow=ncol(predrast))
                                cols = tr$row[i]:(tr$row[i]+dim(predv)[2]-1)
                                v[,cols] <- predv 
                        } else {
                                predrast <- writeValues(predrast, predv, tr$row[i])
                        }
                        pbStep(pb, i) 
                }
                pbClose(pb)
                if (gstatmod) { 
                        names(predrast) <- ln
                }

                if (filename == '') {
                        predrast <- setValues(predrast, as.numeric(v))  # or as.vector
                } else {
                        predrast <- writeStop(predrast)
                }

                return(predrast)
        }
)

139 intersect.R

# Author: Robert J. Hijmans
# Date : December 2011
# Version 1.0
# Licence GPL v3

if (!isGeneric(intersect)) {
        setGeneric(intersect, function(x, y)
                standardGeneric(intersect))
}       
setMethod('intersect', signature(x='Raster', y='ANY'), 
function(x, y) {
        y <- extent(y)
        crop(x, y)
} )
setMethod('intersect', signature(x='Extent', y='ANY'), 
function(x, y) {
        y <- extent(y)

        x@xmin <- max(x@xmin, y@xmin)
        x@xmax <- min(x@xmax, y@xmax)
        x@ymin <- max(x@ymin, y@ymin)
        x@ymax <- min(x@ymax, y@ymax)
        if ((x@xmax <= x@xmin) | (x@ymax <= x@ymin) ) {
                #warning('Objects do not overlap')
                return(NULL)
        }
        return(x)
} )
setMethod('intersect', signature(x='SpatialPoints', y='Raster'), 
function(x, y) {
        y <- extent(y)
        xy <- coordinates(x)
        i <- xy[,1] >= y@xmin & xy[,1] <= y@xmax & xy[,2] >= y@ymin & xy[,2] <= y@ymax
        x[i, ]
} )
.intersectExtent <- function(x, ..., validate=TRUE) {
        objects <- c(x, list(...))
        if (length(objects) == 1) {
                return(extent(x))
        }
        e <- extent(objects[[1]])
        for (i in 2:length(objects)) {
                e2 <- extent(objects[[i]])
                e@xmin <- max(e@xmin, e2@xmin)
                e@xmax <- min(e@xmax, e2@xmax)
                e@ymin <- max(e@ymin, e2@ymin)
                e@ymax <- min(e@ymax, e2@ymax)
        }
        if ((e@xmax <= e@xmin) | (e@ymax <= e@ymin) ) {
                if (validate) {
                        stop('Objects do not intersect')
                } else {
                        return(NULL)
                }
        }
        return(e)
}

140 intersect_sp.R

# Author: Robert J. Hijmans
# Date : December 2011
# Version 1.0
# Licence GPL v3

if (!isGeneric(intersect)) {
        setGeneric(intersect, function(x, y)
                standardGeneric(intersect))
}       
setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPolygons'), 
function(x, y) {
        require(rgeos)
        x <- spChFIDs(x, as.character(1:length(x)))
        y <- spChFIDs(y, as.character(1:length(y)))

        if (! identical(proj4string(x), proj4string(y)) ) {
                warning('non identical CRS')
                y@proj4string <- x@proj4string
        }       

        subs <- rgeos::gIntersects(x, y, byid=TRUE)
        if (sum(subs)==0) {
                warning('polygons do not intersect')
                return(NULL)
        }

        xdata <- .hasSlot(x, 'data')
        ydata <- .hasSlot(y, 'data')
        dat <- NULL
        if (xdata & ydata) {
                nms <- .goodNames(c(colnames(x@data), colnames(y@data)))
                colnames(x@data) <- xnames <- nms[1:ncol(x@data)]
                colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)]
                dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE])
        } else if (xdata) {
                dat <- x@data[NULL, ,drop=FALSE]
                xnames <- colnames(dat)
        } else if (ydata) {
                dat <- y@data[NULL, ,drop=FALSE]
                ynames <- colnames(dat)
        }
        subsx <- apply(subs, 2, any)
        subsy <- apply(subs, 1, any)

        int  <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_not_poly=TRUE)
#       if (inherits(int, SpatialCollections)) {
#               if (is.null(int@polyobj)) { # merely touching, no intersection
#                       #warning('polygons do not intersect')
#                       return(NULL)
#               }
#               int <- int@polyobj
#       }
        if (!inherits(int, 'SpatialPolygons')) {
                # warning('polygons do not intersect')
                return(NULL)
        }
        if (!is.null(dat)) {
                ids <- do.call(rbind, strsplit(row.names(int), ' '))
                rows <- 1:length(ids[,1])
                if (xdata) {
                        idsx <- match(ids[,1], rownames(x@data))
                        dat[rows, xnames] <- x@data[idsx, ]
                } 
                if (ydata) {
                        idsy <- match(ids[,2], rownames(y@data))
                        dat[rows, ynames] <- y@data[idsy, ]
                }
                rownames(dat) <- 1:nrow(dat)
                int <- spChFIDs(int, as.character(1:nrow(dat)))
                int <- SpatialPolygonsDataFrame(int, dat)
        }

        int     
} 
)
setMethod('intersect', signature(x='SpatialPoints', y='SpatialPolygons'), 
function(x, y) {
   if (!identical(proj4string(x), proj4string(y))) {
        warning(non identical CRS)
        y@proj4string <- x@proj4string
    }
    i <- over(as(x, SpatialPoints), as(y, SpatialPolygons))
    i <- which(!is.na(i))
    x[i, ]
}       
)

141 isLonLat.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 0.9
# Licence GPL v3
.isGlobalLonLat <- function(x) {
        res <- FALSE
        tolerance <- 0.1
        scale <- xres(x)
        if (isTRUE(all.equal(xmin(x), -180, tolerance=tolerance, scale=scale)) & 
                isTRUE(all.equal(xmax(x),  180, tolerance=tolerance, scale=scale))) {
                if (couldBeLonLat(x, warnings=FALSE)) {
                        res <- TRUE
                }
        }
        res
}
.couldBeLonLat <- function(...) {
        couldBeLonLat(...)
}
couldBeLonLat <- function(x, warnings=TRUE) {
        crsLL <- isLonLat(x)
        crsNA <- is.na(crsLL)
        e <- extent(x)
        extLL <- (e@xmin > -365 & e@xmax < 365 & e@ymin > -90.1 & e@ymax < 90.1) 
        if (extLL & isTRUE(crsLL)) { 
                return(TRUE)
        } else if (extLL & crsNA) {
                if (warnings) warning('CRS is NA. Assuming it is longitude/latitude')
                return(TRUE)
        } else if (isTRUE(crsLL)) {
                if (warnings) warning('raster has a longitude/latitude CRS, but coordinates do not match that')
                return(TRUE)
        } else {
                return(FALSE)   
        }
}
if (!isGeneric(isLonLat)) {
        setGeneric(isLonLat, function(x)
                standardGeneric(isLonLat))
}       
setMethod('isLonLat', signature(x='Spatial'), 
        function(x){
                isLonLat(projection(x))
    }
)
setMethod('isLonLat', signature(x='BasicRaster'), 
# copied from the SP package (slightly adapted)
#author:
# ...
        function(x){
                p4str <- projection(x)
                if (is.na(p4str) || nchar(p4str) == 0) {
                        return(FALSE)
                } 
                res <- grep(longlat, p4str, fixed = TRUE)
                if (length(res) == 0) {
                        return(FALSE)
                } else {
                        return(TRUE)
                }
    }
)
setMethod('isLonLat', signature(x='character'), 
# copied from the SP package (slightly adapted)
#author:
# ...
        function(x){
                res <- grep(longlat, x, fixed = TRUE)
                if (length(res) == 0) {
                        return(FALSE)
                } else {
                        return(TRUE)
                }
    }
)
setMethod('isLonLat', signature(x='CRS'), 
# copied from the SP package (slightly adapted)
#author:
# ...
        function(x){
                if (is.na(x@projargs)) { 
                        return(FALSE)
                } else {
                        p4str <- trim(x@projargs)
                }       
                if (is.na(p4str) || nchar(p4str) == 0) {
                        return(FALSE)
                } 
                res <- grep(longlat, p4str, fixed = TRUE)
                if (length(res) == 0) {
                        return(FALSE)
                } else {
                        return(TRUE)
                }
    }
)
setMethod('isLonLat', signature(x='ANY'), 
        function(x){
                isLonLat(as.character(x))
    }
)

142 is.na.R

# Authors: Robert J. Hijmans, r.hijmans@gmail.com 
# Date :  January 2009
# Version 0.9
# Licence GPL v3
setMethod(is.na, signature(x='Raster'),
        function(x) {
                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }

                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        return( setValues(r, is.na(getValues(x))) )
                } else {
                        tr <- blockSize(x)

                        pb <- pbCreate(tr$n, label='is.na')                     
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- is.na( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)
                }
        }
)       
setMethod(is.nan, signature(x='Raster'),
        function(x) {
                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        return( setValues(r, is.nan(getValues(x))) )
                } else {
                        tr <- blockSize(x)

                        pb <- pbCreate(tr$n, label='is.na')                     
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- is.nan( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)
                }
        }
)       
setMethod(is.finite, signature(x='Raster'),
        function(x) {
                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        return( setValues(r, is.finite(getValues(x))) )
                } else {
                        tr <- blockSize(x)

                        pb <- pbCreate(tr$n, label='is.na')                     
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- is.finite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)
                }
        }
)       
setMethod(is.infinite, signature(x='Raster'),
        function(x) {
                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        dataType(r) <- 'LOG1S'
                        return( setValues(r, is.infinite(getValues(x))) )
                } else {
                        tr <- blockSize(x)

                        pb <- pbCreate(tr$n, label='is.na')                     
                        r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE )
                        for (i in 1:tr$n) {
                                v <- is.infinite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        pbClose(pb)
                        return(r)
                }
        }
)

143 kernelDens.R

### this is the kde2d function from the MASS packlage with minimal changes
.kde2d <- function (x, y, h, n, lims) {
    nx <- length(x)
    gx <- seq.int(lims[1L], lims[2L], length.out = n[1L])
    gy <- seq.int(lims[3L], lims[4L], length.out = n[2L])
    h <- h/4
    ax <- outer(gx, x, -)/h[1L]
    ay <- outer(gy, y, -)/h[2L]
    tcrossprod(matrix(dnorm(ax), , nx), matrix(dnorm(ay), , nx))/(nx * h[1L] * h[2L])
}
.kernelDens <- function(p, x, bandwidth, ...) {

        .bandwidth.nrd <- function(x) {
        ### this function is from the MASS package
                r <- quantile(x, c(0.25, 0.75))
                h <- (r[2L] - r[1L])/1.34
                4 * 1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5)
        }

    if(missing(bandwidth)) {
                bw <- c(.bandwidth.nrd(p[,1]), .bandwidth.nrd(p[,2]))
        } else {
                bw <- rep(bandwidth, length.out = 2L)
        }
        v <- .kde2d(p[,1], p[,2], bw, dim(x)[1:2], as.vector(t(bbox(x))))
        v <- t(v)
        v <- v[nrow(v):1, ]
        setValues(x, v)
}
#a = kernelDens(xy, r)

144 kml_multiple.R

# Derived from functions GE_SpatialGrid and kmlOverlay 
# in the maptools package by Duncan Golicher, David Forrest and Roger Bivand 
# Adaptation for the raster package by Robert J. Hijmans
# Date : October 2011
# Version 0.9
# Licence GPL v3
.zipKML <- function(kml, image, zip, overwrite=FALSE) {
        if (zip == ) {
                zip <- Sys.getenv('R_ZIPCMD', 'zip')
        }
        if (zip !=  ) {
                wd <- getwd()
                on.exit( setwd(wd) )
                setwd(dirname(kml))
                kml <- basename(kml)
                kmz <- extension(kml, '.kmz')

                if (file.exists(kmz)) {
                        if (overwrite) {
                                file.remove(kmz)
                        } else {
                                stop('kml file created, but kmz file exists, use overwrite=TRUE to overwrite it')
                        }
                }       

                image <- basename(image)
                if (zip=='7z') {
                        kmzzip <- extension(kmz, '.zip')
                        cmd <- paste(zip, 'a', kmzzip, kml, image, collapse= )
                        file.rename(kmzzip, kmz)
                } else {
                        cmd <- paste(c(zip, kmz, kml, image), collapse= )
                }
                sss <- try( system(cmd, intern=TRUE), silent=TRUE )
                if (file.exists(kmz)) {
                        files <- c(kml, image)
                        files <- files[file.exists(files)]
                        x <- file.remove(files)
                        return(invisible(kmz))
                } else {
                        return(invisible(kml))
                }
        } else {
                return(invisible(kml))
        }
}
setMethod('KML', signature(x='RasterStackBrick'), 
function (x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) {
    if (! couldBeLonLat(x)) { 
        stop(CRS of x must be longitude/latitude)
        }
        stopifnot(hasValues(x))
        if (missing(filename)) { 
                filename <- extension(basename(rasterTmpFile('G_')), '.kml')
        }

        nl <- nlayers(x)
        if (is.null(time)) { 
                dotime <- FALSE
                atime <- time
        } else {
                dotime <- TRUE
                if (length(time) == nl) {
                        when <- TRUE
                } else if (length(time) == nl+1) {
                        when <- FALSE
                } else {
                        stop('length(time) should equall nlayers(x) for when, or (nlayers(x)+1) for begin-end')
                }
        }
        x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE)
        kmlfile <- filename
        extension(kmlfile) <- '.kml'
        if (file.exists(kmlfile)) {
                if (overwrite) {
                        file.remove(kmlfile)
                } else {
                        stop('kml file exists, use overwrite=TRUE to overwrite it')
                }
        }       


        name <- names(x)
    kml <- c('<?xml version=1.0 encoding=UTF-8?>', '<kml xmlns=http://www.opengis.net/kml/2.2>')
    kml <- c(kml, c(<Folder>, paste(<name>, extension(basename(filename), ''), </name>, sep='')))
    e <- extent(x)
    latlonbox <- c(\t<LatLonBox>, paste(\t\t<north>, e@ymax, </north><south>,  e@ymin, </south><east>, 
                                                e@xmax, </east><west>, e@xmin, </west>, sep = ), \t</LatLonBox>, </GroundOverlay>)
        imagefile <- paste(extension(filename, ''), _, 1:nl, .png, sep=)


        for (i in 1:nl) {
                png(filename = imagefile[i], width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg=transparent)
                if (!is.na(colNA)) {
                        par(mar=c(0,0,0,0), bg=colNA)
                } else {
                        par(mar=c(0,0,0,0))     
                }

                if (R.Version()$minor >= 13) {
                        image(x[[i]], col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...)
                } else {
                        image(x[[i]], col=col, axes=FALSE, maxpixels=maxpixels, ...)
                }
                dev.off()
                a <- c(<GroundOverlay>, paste(\t<name>, name[i], </name>, sep=''))
                if (dotime) {
                        if (when) {
                                atime <- c(\t<TimeSpan>, paste(\t\t<when>, time[i], </when>, sep=''), \t</TimeSpan>)                    
                        } else {
                                atime <- c(\t<TimeSpan>, paste(\t\t<begin>, time[i], </begin>, sep=''), 
                                        paste(\t\t<end>, time[i+1], </end>, sep=''), \t</TimeSpan>)
                        }
                }
                kml <- c(kml, a, atime, paste(\t<Icon><href>, basename(imagefile[i]), </href></Icon>, sep=''), latlonbox)
        }
    kml <- c(kml, </Folder>, </kml>)
    cat(paste(kml, sep=, collapse=\n), file=kmlfile, sep = )
        .zipKML(kmlfile, imagefile, zip, overwrite=overwrite)
}
)

145 kml.R

# Derived, with only minor changes, from functions GE_SpatialGrid and kml Overlay 
# in the maptools package. These were written by Duncan Golicher, David Forrest and Roger Bivand 
# Adaptation for the raster packcage by Robert J. Hijmans, 
# Date : March 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(KML)) {
        setGeneric(KML, function(x, ...)
                standardGeneric(KML))
}       
setMethod('KML', signature(x='Spatial'), 
        function (x, filename, zip='', overwrite=FALSE, ...) {
                .requireRgdal()
                if (! is.na(projection(x))) {
                        if (! isLonLat(x) ) {
                                warning('transforming data to longitude/latitude')
                                spTransform(x, CRS('+proj=longlat +datum=WGS84'))
                        }
                }

                if (! .hasSlot(x, 'data') ) {
                        x <- addAttrToGeom(x, data.frame(id=1:length(x)), match.ID=FALSE)
                }

                extension(filename) <- '.kml'
                if (file.exists(filename)) {
                        if (overwrite) {
                                file.remove(filename)
                        } else {
                                stop('file exists, use overwrite=TRUE to overwrite it')
                        }
                }

                name <- deparse(substitute(x))
                writeOGR(x, filename, name, 'KML')
                .zipKML(filename, '', zip, overwrite=overwrite) 
        }
)


setMethod('KML', signature(x='RasterLayer'), 
function (x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) {
    if (! couldBeLonLat(x)) { 
        stop(CRS of x must be longitude / latitude)
        }

        if (nlayers(x) > 1) {
                x <- x[[1]]
        }
        stopifnot(hasValues(x))
        if (missing(filename)) { 
                filename <- extension(basename(rasterTmpFile('G_')), '.kml')
        }

        x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE)
        imagefile <- filename
        extension(imagefile) <- '.png'
        kmlfile <- kmzfile <- filename
        extension(kmlfile) <- '.kml'

        if (file.exists(kmlfile)) {
                if (overwrite) {
                        file.remove(kmlfile)
                } else {
                        stop('kml file exists, use overwrite=TRUE to overwrite it')
                }
        }


        png(filename = imagefile, width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg=transparent)
        if (!is.na(colNA)) {
                par(mar=c(0,0,0,0), bg=colNA)
        } else {
                par(mar=c(0,0,0,0))     
        }
        image(x, col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...)
        dev.off()
        name <- names(x)[1]
        if (name == ) { name <- 'x' }
    kml <- c('<?xml version=1.0 encoding=UTF-8?>', '<kml xmlns=http://www.opengis.net/kml/2.2>', <GroundOverlay>)
    kmname <- paste(<name>, name, </name>, sep = )
    icon <- paste(<Icon><href>, basename(imagefile), </href><viewBoundScale>0.75</viewBoundScale></Icon>, sep = )
    e <- extent(x)
    latlonbox <- c(\t<LatLonBox>, paste(\t\t<north>, e@ymax, </north><south>,  e@ymin, </south><east>, e@xmax, </east><west>, e@xmin, </west>, sep = ), \t</LatLonBox>)
    footer <- </GroundOverlay></kml>

    kml <- c(kml, kmname, icon, latlonbox, footer)

    cat(paste(kml, sep=, collapse=\n), file=kmlfile, sep=)

        .zipKML(kmlfile, imagefile, zip, overwrite=overwrite)
}
)

146 layerize.R

# Author: Robert J. Hijmans
# Date : August 2012
# Version 1.0
# Licence GPL v3
if (!isGeneric(layerize)) {
        setGeneric(layerize, function(x, y, ...)
                standardGeneric(layerize))
}
setMethod('layerize', signature(x='RasterLayer', y='missing'), 
        function(x, classes=NULL, falseNA=FALSE, filename='', ...) {

                doC <- list(...)$doC
                if (is.null(doC)) doC <- TRUE           
                if (is.null(classes)) {
                        classes <- as.integer( sort(unique(x)) )
                } else {
                        classes <- as.integer(classes) 
                }

                out <- raster(x)
                if (length(classes) > 1) {
                        out <- brick(out, nl=length(classes))
                }
                names(out) <- classes

                if (canProcessInMemory(out)) {
                        v <- as.integer(getValues(x))
                        if (doC) {
                                v <- .Call(layerize, v, as.integer(classes), as.integer(falseNA), PACKAGE='raster')
                                v <- matrix(v, ncol=length(classes))
                        } else {
                                v <- t( apply(matrix(v), 1, function(x) x == classes) )
                                if (falseNA) {
                                        v[!v] <- NA
                                }
                        }
# alternative approach (assuming sorted classes)
# alternative approach (assuming sorted classes)
#                       vv <- cbind(1:length(v), as.integer(as.factor(v)))
#                       if (falseNA) {
#                               v <- matrix(NA, nrow=ncell(out), ncol=nlayers(out))
#                       } else {
#                               v <- matrix(0, nrow=ncell(out), ncol=nlayers(out))
#                       }
#                       v[vv] <- 1

                        out <- setValues(out, v*1)
                        if (filename != '') {
                                out <- writeRaster(out, filename, ...)
                        }
                        return(out)
                }

# else to disk          
##                      out <- writeStart(out, filename=filename, datatype='INT2S', ...)
#               } else {
                out <- writeStart(out, filename=filename, ...)
#               }
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='layerize', ...)
                fNA <- as.integer(falseNA)
                if (doC) {
                        for (i in 1:tr$n) {
                                v <- as.integer(getValues(x, tr$row[i], tr$nrows[i]))
                                v <- .Call(layerize, v, classes, fNA, PACKAGE='raster')
                                v <- matrix(v, ncol=length(classes))
                                out <- writeValues(out, v*1, tr$row[i])
                                pbStep(pb, i) 
                        }
                } else {
                        for (i in 1:tr$n) {
                                v <- getValues(x, tr$row[i], tr$nrows[i]) 
                                v <- t( apply(matrix(v, ncol=1), 1, function(x) x == classes) )
                                if (falseNA) {
                                        v[!v] <- NA
                                }
                                out <- writeValues(out, v*1, tr$row[i])
                                pbStep(pb, i) 
                        }
                }
                pbClose(pb)
                writeStop(out)  
        }
)
setMethod('layerize', signature(x='RasterLayer', y='RasterLayer'), 
function(x, y, classes=NULL, filename='', ...) { 
        resx <- res(x)
        resy <- res(y)
        if (! all( resy > resx) ) {
                stop(x and y resolution of object y should be (much) larger than that of object x)
        }

        int <- intersect(extent(x), extent(y))
        if (is.null(int)) {
                return(raster(y))
        }
        if (is.null(classes)) {
                classes <- as.integer( sort(unique(x)))
        }       
        out <- raster(y)
        if (length(classes) > 1) {
                out <- brick(out, nl=length(classes))
        }
        names(out) <- paste('count_', as.character(classes), sep='')

        if (canProcessInMemory( out )) {
                b <- crop(x, int)
                xy <- xyFromCell(b, 1:ncell(b))
                mc <- cellFromXY(out, xy)
                b <- as.integer(getValues(b))
                if (!is.null(classes)) {
                        b[! b %in% classes] <- NA
                }       
                v <- table(mc, b)
                cells <- as.integer(rownames(v))
                m <- match(cells, 1:ncell(out))
                cn <- as.integer(colnames(v))
                res <- matrix(NA, nrow=ncell(out), ncol=length(cn))
                for (i in 1:length(cn)) {
                         res[m,i] <- v[,i]
                }

                names(out) <- paste('count_', as.character(cn), sep='')
                out <- setValues(out, res)

                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                }
                return(out)
        } 
        #  else 

        out <- writeStart(out, filename=filename, ...)
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, label='layerize', ...)
        for(i in 1:tr$n) {              
                e <- extent(xmin(y), xmax(y), yFromRow(y, tr$row[i]+tr$nrows[i]-1)  - 0.5 * yres(y), yFromRow(y, tr$row[i])+0.5 * yres(y))
                int <- intersect(e, extent(x)) 
                res <- matrix(NA, nrow=tr$nrows[i] * ncol(y), ncol=length(classes))
                if (!is.null(int)) {
                        b <- crop(x, int)
                        xy <- xyFromCell(b, 1:ncell(b))
                        mc <- cellFromXY(y, xy)
                        v <- table(mc, as.integer(getValues(b)))
                        cells <- as.integer(rownames(v))
                        modcells <- cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+ tr$nrows[i]-1, ncol(y))
                        m <- match(cells, modcells)
                        cn <- as.integer(colnames(v))
                        mm <- match(cn, classes)
                        for (j in 1:length(cn)) {
                                res[, mm[j]] <- v[, j]
                        }
                }       
                out <- writeValues(out, res, tr$row[i])
        }               
        out <- writeStop(out)
        pbClose(pb)
        out     
}
)

147 layerStats.R

# Jonathan Greenberg and Robert Hijmans
# Date : April 2012
# Version 1.0
# Licence GPL v3
# Computation of the weighted covariance and (optionally) weighted means of bands in an Raster.
# based on code by Mort Canty
layerStats <- function(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) {

        stat <- tolower(stat)
        stopifnot(stat %in% c('cov', 'weighted.cov', 'pearson'))
        stopifnot(is.logical(asSample) & !is.na(asSample))
        nl <- nlayers(x)
        n <- ncell(x)
        mat <- matrix(NA, nrow=nl, ncol=nl)
        colnames(mat) <- rownames(mat) <- names(x)
        pb <- pbCreate(nl^2, label='layerStats', ...)   

        if (stat == 'weighted.cov') {
                if (missing(w)) {
                        stop('to compute weighted covariance a weights layer should be provided')
                }
                stopifnot( nlayers(w) == 1 )
                if (na.rm) {
                # a cell is set to NA if it is NA in any layer. That is not ideal, but easier and quicker
                        nas <- calc(x, function(i) sum(i)) * w
                        x <- mask(x, nas)
                        w <- mask(w, nas)
                }
                sumw <- cellStats(w, stat='sum', na.rm=na.rm) 
                means <- cellStats(x * w, stat='sum', na.rm=na.rm) / sumw
                sumw <- sumw - asSample

                x <- (x - means) * sqrt(w)

                for(i in 1:nl) {
                        for(j in i:nl) {
                                r <- raster(x, layer=i) * raster(x,layer=j)
                                v <- cellStats(r, stat='sum', na.rm=na.rm) / sumw
                                mat[j,i] <- mat[i,j] <- v
                                pbStep(pb)
                        }
                }
                pbClose(pb)
                cov.w <- list(mat, means)
                names(cov.w) <- c(weigthed covariance, weighted mean)
                return(cov.w)           

        } else if (stat == 'cov') {
                means <- cellStats(x, stat='mean', na.rm=na.rm) 
                x <- (x - means)

                for(i in 1:nl) {
                        for(j in i:nl) {
                                r <- raster(x, layer=i) * raster(x, layer=j)
                                if (na.rm) {
                                        v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - cellStats(r, stat='countNA') - asSample)
                                } else {
                                        v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - asSample)
                                }
                                mat[j,i] <- mat[i,j] <- v
                                pbStep(pb)
                        }
                }
                pbClose(pb)
                covar <- list(mat, means)
                names(covar) <- c(covariance, mean)
                return(covar)           

        } else if (stat == 'pearson') {
                means <- cellStats(x, stat='mean', na.rm=na.rm) 
                sds <- cellStats(x, stat='sd', na.rm=na.rm) 
                x <- (x - means)

                for(i in 1:nl) {
                        for(j in i:nl) {
                                r <- raster(x, layer=i) * raster(x, layer=j)
                                if (na.rm) {
                                        v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - cellStats(r, stat='countNA') - asSample) * sds[i] * sds[j])
                                } else {
                                        v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - asSample) * sds[i] * sds[j])
                                }
                                mat[j,i] <- mat[i,j] <- v
                                pbStep(pb)
                        }
                }
                pbClose(pb)
                covar <- list(mat, means)
                names(covar) <- c(pearson correlation coefficient, mean)
                return(covar)

        }
}

148 makeProjString.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  January 2009
# Version 0.9
# Licence GPL v3
.newCRS <- function(projs) {
        if (is.null(projs)) {
                prj <- CRS()
        } else if (is.na(projs)) {
                prj <- CRS()
        } else if (nchar(projs) < 3) { 
                prj <- CRS()
        } else {
                projs <- trim(projs)
                prj <- try(CRS(projs), silent = TRUE)
                if (class(prj) == try-error) { 
                        warning(paste(projs, 'is not a valid PROJ.4 CRS string')) 
                        prj <- CRS()
                }
        }
        return(prj)
}
.makeProj <- function(projection='longlat', ..., ellipsoid=, datum=, asText=TRUE) {
        prj <- rgdal::projInfo(proj)
        ell <- rgdal::projInfo(ellps)
        dat <- rgdal::projInfo(datum)
        projection <- trim(projection)
        ellipsoid <- trim(ellipsoid)
        datum <- trim(datum)
        if (!(projection %in% prj[,1])) {
                stop(unknown projection. See rgdal::projInfo()) 
        } else {
                pstr <- paste('+proj=',projection, sep=)
                projname <- as.vector(prj[which(prj[,1]==projection), 2])
        }
        pargs <- list(...)
        if ( length(pargs) > 0 ) {
                for (i in 1:length(pargs)) {
                        pstr <- paste(pstr, ' +', pargs[[i]], sep=)
                }
        }
        if (ellipsoid != ) {
                if (!(ellipsoid %in% ell[,1])) { 
                        stop(unknown ellipsoid. See rgdal::projInfo('ellps')) 
                } else {
                        pstr <- paste(pstr,  +ellps=, ellipsoid, sep=)
#                       ellipname <- ell[which(ell[,1]==ellipsoid), 2]
                }
        }
        if (datum != ) {
                if (!(datum %in% dat[,1])) { 
                        stop(unknown datum. See rgdal::projInfo('datum')) 
                } else {
                        pstr <- paste(pstr,  +datum=, datum, sep=)
#                       datumname <- as.vector(dat[which(dat[,1]==datum), 2])
                }
        }
        cat(Projection: , projname[1], \n)
        crs <- .newCRS(pstr)
        if (asText) { 
                return(trim(crs@projargs))
        } else {
                return(crs)
        }
}

149 makeRasterList.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date : September 2008
# Version 0.9
# Licence GPL v3
.addToList <- function(x, r, compare, giveError, unstack) {
        if (class(r) == 'character') {
                r <- raster(r)
                # or r <- unstack(stack(r, -1)) ???
                if (compare & length(x)>0) { 
                        compareRaster(x[[1]], r)  
                }
                return( c(x, r) )
        } else if (! extends(class(r), 'Raster')) {
                if (giveError) {
                        stop('... arguments must be a filename or objects that extend the Raster class')
                } else {
                        return(x)
                }
        } else if (unstack & inherits(r, 'RasterStackBrick')) { 
                if ( compare & length(x) > 0 ) { 
                        compareRaster(x[[1]], r)  
                }
                return( c(x, unstack(r)) )
        } else {
                if (compare & length(x) > 0) { 
                        compareRaster(x[[1]], r)  
                }
                return( c(x, r) )       
        } 
}
.makeRasterList <- function(..., compare=FALSE, giveError=FALSE, unstack=TRUE) {
        arg <- list(...)
        x <- list()
        for (i in seq(along=arg)) {
                if (class(arg[[i]]) == 'list') {
                        for (j in seq(along=arg[[i]])) {
                                x <- .addToList(x, arg[[i]][[j]], compare=compare, giveError=giveError, unstack=unstack) 
                        }
                } else {
                        x <- .addToList(x, arg[[i]], compare=compare, giveError=giveError, unstack=unstack) 
                }
        }
        fdim <- sapply(x, fromDisk) & sapply(x, inMemory)
        if (sum(fdim) > 0) {
                x[fdim] <- sapply(x[fdim], clearValues)
        }
        hv <- sum(sapply(x, hasValues))
        if (hv < length(x)) {
                if (sum(hv) == 0) {
                        x <- x[1]
                } else {
                        x <- x[hv]
                        warning('layer(s) with no data ignored')
                }
        }
        return(x)
}

150 mask.R

# Author: Robert J. Hijmans
# Date : November 2009
# Version 1.0
# Licence GPL v3
if (!isGeneric(mask)) {
        setGeneric(mask, function(x, mask, ...)
                standardGeneric(mask))
}       
setMethod('mask', signature(x='Raster', mask='Spatial'), 
function(x, mask, filename=, inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...){ 
        mask <- rasterize(mask, x, 1, silent=TRUE)
        mask(x, mask, filename=filename, inverse=inverse, maskvalue=NA, updatevalue=updatevalue, ...)
} )
setMethod('mask', signature(x='RasterLayer', mask='RasterLayer'), 
function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ 
        maskvalue <- maskvalue[1]
        updatevalue <- updatevalue[1]
        compareRaster(x, mask)
        ln <- names(x)
        out <- raster(x)
        names(out) <- ln                

        if ( canProcessInMemory(x, 3)) {
                x <- getValues(x)
                mask <- getValues(mask)
                if (is.na(maskvalue)) {
                        if (updateNA) {
                                if (inverse) {
                                        x[!is.na(mask)] <- updatevalue
                                } else {
                                        x[is.na(mask)] <- updatevalue
                                }                       
                        } else {
                                if (inverse) {
                                        x[!is.na(mask) & !is.na(x)] <- updatevalue
                                } else {
                                        x[is.na(mask) & !is.na(x)] <- updatevalue
                                }
                        }
                } else {
                        if (updateNA) {
                                if (inverse) {
                                        x[mask != maskvalue] <- updatevalue
                                } else {
                                        x[mask == maskvalue] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[mask != maskvalue & !is.na(x)] <- updatevalue
                                } else {
                                        x[mask == maskvalue & !is.na(x)] <- updatevalue
                                }
                        }
                }
                x <- setValues(out, x)
                if (filename != '') {
                        x <- writeRaster(x, filename, ...)
                }
                return(x)

        } else {
                if (filename=='') {     
                        filename <- rasterTmpFile() 
                }
                out <- writeStart(out, filename=filename, ...)
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='mask', ...)
                if (is.na(updatevalue)) {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m)] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        }               
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m)] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m != maskvalue] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        }               
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m==maskvalue] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        }
                } else {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        }               
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (updateNA) {
                                        if (inverse) {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m != maskvalue] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                }               
                                        } else {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m==maskvalue] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        }                               
                                } else {
                                        if (inverse) {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m != maskvalue & !is.na(v)] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                }               
                                        } else {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m==maskvalue & !is.na(v)] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        }
                                }
                        }
                }
                pbClose(pb)
                out <- writeStop(out)
                names(out) <- ln                
                return(out)
        }
}
)
setMethod('mask', signature(x='RasterStackBrick', mask='RasterLayer'), 
function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ 
        compareRaster(x, mask)
        maskvalue <- maskvalue[1]
        updatevalue <- updatevalue[1]

        out <- brick(x, values=FALSE)
        names(out) <- ln <- names(x)

        if (canProcessInMemory(x, nlayers(x)+4)) {
                x <- getValues(x)

                if (is.na(maskvalue)) {
                        if (updateNA) {
                                if (inverse) {
                                        x[!is.na(getValues(mask))] <- updatevalue
                                } else {
                                        x[is.na(getValues(mask))] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue
                                } else {
                                        x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue
                                }
                        }
                } else {
                        if (updateNA) {
                                if (inverse) {
                                        x[getValues(mask) != maskvalue] <- updatevalue
                                } else {
                                        x[getValues(mask) == maskvalue] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[getValues(mask) != maskvalue & !is.na(x)] <- updatevalue
                                } else {
                                        x[getValues(mask) == maskvalue & !is.na(x)] <- updatevalue
                                }
                        }
                }
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                } 
                return(out)

        } else {
                if ( filename=='') { 
                        filename <- rasterTmpFile() 
                }
                out <- writeStart(out, filename=filename, ...)
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='mask', ...)
                if (is.na(updatevalue)) {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m)] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m)] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m != maskvalue] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m == maskvalue] <- NA
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        }

                } else {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {

                                if (updateNA) {
                                        if (inverse) {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m != maskvalue] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        } else {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m == maskvalue] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        }

                                } else {

                                        if (inverse) {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m != maskvalue & !is.na(v)] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        } else {
                                                for (i in 1:tr$n) {
                                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                        m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                        v[m == maskvalue & !is.na(v)] <- updatevalue
                                                        out <- writeValues(out, v, tr$row[i])
                                                        pbStep(pb, i)
                                                } 
                                        }
                                }
                        }
                }
                pbClose(pb)
                out <- writeStop(out)
                names(out) <- ln
                return(out)
        }
}
)
setMethod('mask', signature(x='RasterLayer', mask='RasterStackBrick'), 
function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ 
        compareRaster(x, mask)
        out <- brick(mask, values=FALSE)
        maskvalue <- maskvalue[1]
        updatevalue <- updatevalue[1]

        if (canProcessInMemory(mask, nlayers(x)*2+2)) {
                x <- getValues(x)
                x <- matrix(rep(x, nlayers(out)), ncol=nlayers(out))

                if (updateNA) {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        x[!is.na(getValues(mask))] <- updatevalue
                                } else {
                                        x[is.na(getValues(mask))] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[getValues(mask)!=maskvalue] <- updatevalue
                                } else {
                                        x[getValues(mask)==maskvalue] <- updatevalue
                                }
                        }
                } else {        
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue
                                } else {
                                        x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[getValues(mask)!=maskvalue & !is.na(x)] <- updatevalue
                                } else {
                                        x[getValues(mask)==maskvalue & !is.na(x)] <- updatevalue
                                }
                        }
                }       
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                } 
                return(out)

        } else {

                if ( filename=='') { filename <- rasterTmpFile() }
                out <- writeStart(out, filename=filename, ...)
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='mask', ...)
                if (updateNA) {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m != maskvalue] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m == maskvalue] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        }
                } else {

                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[!is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[is.na(m) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m != maskvalue & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out))
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[m == maskvalue & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        }
                }

                pbClose(pb)
                out <- writeStop(out)
                return(out)
        }
}
)
setMethod('mask', signature(x='RasterStackBrick', mask='RasterStackBrick'), 
function(x, mask, filename=, inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ 
        nlx <- nlayers(x)
        nlk <- nlayers(mask)
        if ( nlx != nlk ) {
                if (nlx == 1) {
                        x <- raster(x, 1)
                        return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...))
                } 
                if (nlk == 1) {
                        mask <- raster(mask, 1)
                        return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...))
                }

                if (! ((nlx > nlk) & (nlx %% nlk == 0)) ) {
                        stop('number of layers of x and mask must be the same,\nor one of the two should be 1, or the number of layers of x\nshould be divisible by the number of layers of mask')
                }
        }

        updatevalue <- updatevalue[1]
        maskvalue <- maskvalue[1]

        compareRaster(x, mask)
        out <- brick(x, values=FALSE)
        ln <- names(x)
        names(out) <- ln

        if (canProcessInMemory(x, nlx*2)) {
                x <- getValues(x)

                if (updateNA) {

                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        x[!is.na(as.vector(getValues(mask)))] <- updatevalue
                                } else {
                                        x[is.na(as.vector(getValues(mask)))] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[as.vector(getValues(mask)) != maskvalue] <- updatevalue
                                } else {
                                        x[as.vector(getValues(mask)) == maskvalue] <- updatevalue
                                }
                        }

                } else {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        x[!is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue
                                } else {
                                        x[is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue
                                }
                        } else {
                                if (inverse) {
                                        x[as.vector(getValues(mask)) != maskvalue  & !is.na(x)] <- updatevalue
                                } else {
                                        x[as.vector(getValues(mask)) == maskvalue & !is.na(x)] <- updatevalue
                                }
                        }
                }
                out <- setValues(out, x)
                if (filename != '') {
                        out <- writeRaster(out, filename, ...)
                        names(out) <- ln
                } 
                return(out)

        } else {
                if ( filename=='') { filename <- rasterTmpFile() }
                out <- writeStart(out, filename=filename, ...)
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='mask', ...)
                if (updateNA) {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(!is.na(m))] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(is.na(m))] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(m != maskvalue)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(m == maskvalue)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        }       
                                }
                        }
                } else {
                        if (is.na(maskvalue)) {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(!is.na(m)) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(is.na(m)) &  !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                }
                        } else {
                                if (inverse) {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(m != maskvalue) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        } 
                                } else {
                                        for (i in 1:tr$n) {
                                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                                m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] )
                                                v[as.vector(m == maskvalue) & !is.na(v)] <- updatevalue
                                                out <- writeValues(out, v, tr$row[i])
                                                pbStep(pb, i)
                                        }       
                                }
                        }
                }
                pbClose(pb)
                out <- writeStop(out)
                names(out) <- ln
                return(out)
        }
}
)

151 match.R

# Author: Robert J. Hijmans
# Date : October 2011
# October 2011
# version 1
# Licence GPL v3
if (!isGeneric(%in%)) {
        setGeneric(%in%, function(x, table)
                standardGeneric(%in%))
}       
setMethod(%in%, signature(x='Raster', table='ANY'),
        function(x, table) {
                calc(x, function(x) x %in% table)
        }
)
if (!isGeneric(match)) {
        setGeneric(match, function(x, table, nomatch=NA_integer_, incomparables=NULL)
                standardGeneric(match))
}       
setMethod(match, signature(x='Raster', table='ANY', nomatch='ANY', incomparables='ANY'),
        function(x, table, nomatch, incomparables) {
                calc(x, function(x) match(x, table, nomatch, incomparables))
        }
)

152 math.R

# Authors: Robert J. Hijmans
# Date :  January 2009
# Version 0.9
# Licence GPL v3
setMethod(Math, signature(x='Raster'),
    function(x){ 
                if (!hasValues(x)) {
                        return(x)
                }
                #funname <- as.character(sys.call(sys.parent())[[1]])
                funname <- .Generic

                nl <- nlayers(x)
                if (nl > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (substr(funname, 1, 3) == 'cum' ) { 
                        if (nl == 1) {
                                if (canProcessInMemory(r, 3)) {
                                        r <- setValues(r, do.call(funname, list(values(x))))
                                } else {
                                        tr <- blockSize(x)
                                        pb <- pbCreate(tr$n, label='math')                      
                                        r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                                        x <- readStart(x)
                                        last <- 0
                                        for (i in 1:tr$n) {
                                                v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i])
                                                if (i==1) {
                                                        v <- do.call(funname, list(v))
                                                } else {
                                                        v <- do.call(funname, list(c(last, v)))[-1]
                                                } 
                                                last <- v[length(v)]
                                                r <- writeValues(r, v, tr$row[i])
                                                pbStep(pb, i) 
                                        }
                                        r <- writeStop(r)
                                        x <- readStop(x)
                                        pbClose(pb)
                                }
                                return(r)
                        }

                        if (canProcessInMemory(r, 3)) {
                                r <- setValues(r, t( apply(getValues(x), 1, funname)) )
                        } else {

                                tr <- blockSize(x)
                                pb <- pbCreate(tr$n, label='math')
                                r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE )
                                x <- readStart(x)
                                for (i in 1:tr$n) {
                                        v <- t( apply(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), 1, funname) )
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i) 
                                }
                                r <- writeStop(r)
                                x <- readStop(x)
                                pbClose(pb)
                        }

                } else {

                        if (canProcessInMemory(r, 3)) {
                                r <- setValues(r, callGeneric(getValues(x)))
                        } else {
                                if (funname %in% c('floor', 'ceiling', 'trunc')) {
                                        datatype <- 'INT4S'
                                } else {
                                        datatype <- .datatype()
                                }

                                tr <- blockSize(x)
                                pb <- pbCreate(tr$n, label='math')
                                r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, overwrite=TRUE )
                                x <- readStart(x)
                                for (i in 1:tr$n) {
                                        v <- callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) )
                                        r <- writeValues(r, v, tr$row[i])
                                        pbStep(pb, i) 
                                }
                                r <- writeStop(r)
                                x <- readStop(x)
                                pbClose(pb)
                        }
                }
                return(r)
        }
)
setMethod(Math, signature(x='RasterLayerSparse'),
    function(x){ 
                if (!hasValues(x)) {
                        return(x)
                }
#               funname <- as.character(sys.call(sys.parent())[[1]])
                funname <- .Generic
                if (substr(funname, 1, 3) == 'cum' ) { 
                        setValues(x, do.call(funname, list(x@data@values)))
                } else {
                        setValues(x, callGeneric(x@data@values))
                }
        }
)
setMethod(Math2, signature(x='Raster'), 
        function (x, digits=0) {

                digits <- round(digits)

                if (nlayers(x) > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        r <- setValues(r, callGeneric( getValues(x), digits))
                } else {
                        if (digits <= 0) {
                                datatype <- 'INT4S'
                        } else {
                                datatype <- .datatype()
                        }
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='math')
                        r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, format=.filetype(), overwrite=TRUE )
                        x <- readStart(x)

                        for (i in 1:tr$n) {
                                v <- callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), digits )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        x <- readStop(x)
                        pbClose(pb)
                }
                return(r)
        }
)
if (!isGeneric(log)) {
        setGeneric(log, function(x, ...)
                standardGeneric(log))
}       
setMethod(log, signature(x='Raster'),
    function(x, base=exp(1)){ 

                nl <- nlayers(x)
                if (nl > 1) {
                        r <- brick(x, values=FALSE)
                } else {
                        r <- raster(x)
                }
                if (canProcessInMemory(r, 3)) {
                        r <- setValues(r, log(values(x), base=base))
                } else {
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='math')
                        r <- writeStart(r, '', overwrite=TRUE )
                        x <- readStart(x)

                        for (i in 1:tr$n) {
                                v <- log( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), base=base )
                                r <- writeValues(r, v, tr$row[i])
                                pbStep(pb, i) 
                        }
                        r <- writeStop(r)
                        x <- readStop(x)

                        pbClose(pb)
                }
                return(r)
        }
)

153 maxDataType.R

.maxDatatype <- function(x) {
        x <- sort(x)
        x <- x[substr(x, 1, 3)== substr(x[1], 1, 3)] 
        size <- max(as.integer(substr(x, 4, 4)))
        if (substr(x[1], 1, 3) == 'FLT') {
                return( paste('FLT', size, 'S', sep=) )
        } else {
                # need to do better than this
                return( 'INT4S' )
        }
}

154 mean.R

# Author: Robert J. Hijmans
# Date :  October 2008
# revised: October 2011
# Version 1.0
# Licence GPL v3
setMethod(mean, signature(x='Raster'),
        function(x, ..., trim=NA, na.rm=FALSE){

                if (!is.na(trim)) {     warning(argument 'trim' is ignored) }

                if (as.integer(R.Version()$minor) < 15) {
                        old <- TRUE
                } else {
                        old <- FALSE
                }
                dots <- list(...)
                if (length(dots) > 0) {
                        x <- stack(.makeRasterList(x, ...))
                        add <- unlist(.addArgs(...))
                } else {
                        add <- NULL
                }
                out <- raster(x)
                d <- dim(x)
                nc <- ncell(out)
                if (is.null(add)) {
                        if (canProcessInMemory(x)) {
                                x <- getValues(x)
                                if (old) {
                                        x <- setValues(out, rowMeans(x, na.rm=na.rm))
                                } else {
                                        x <- setValues(out, .rowMeans(x, nc, d[3], na.rm=na.rm))
                                }
                                return(x)
                        }
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='mean')
                        out <- writeStart(out, filename=)
                        x <- readStart(x, ...)
                        if (old) {
                                for (i in 1:tr$n) {
                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                        v <- rowMeans(v, na.rm=na.rm)
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        } else {
                                for (i in 1:tr$n) {
                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                        v <- .rowMeans(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm)
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }
                        pbClose(pb)
                        x <- readStop(x)
                        return( writeStop(out) )
                } else {
                        d3 <- d[3] + length(add)
                        if (canProcessInMemory(x)) {
                                if (length(add) == 1) {
                                        x <- cbind(getValues(x), add)
                                } else {
                                        x <- getValues(x)
                                        x <- t(apply(x, 1, function(i) c(i, add)))
                                }
                                if (old) {
                                        x <- setValues(out, rowMeans(x, na.rm=na.rm))                           
                                } else {
                                        x <- setValues(out, .rowMeans(x, nc, d3, na.rm=na.rm))
                                }
                                return(x)
                        }
                        tr <- blockSize(x)
                        pb <- pbCreate(tr$n, label='mean')
                        out <- writeStart(out, filename=)
                        x <- readStart(x, ...)
                        if (old) {
                                for (i in 1:tr$n) {
                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                        v <- t(apply(v, 1, function(i) c(i, add)))
                                        v <- rowMeans(v, na.rm=na.rm)
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }                       
                        } else {
                                for (i in 1:tr$n) {
                                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                        v <- t(apply(v, 1, function(i) c(i, add)))
                                        v <- .rowMeans(v, tr$nrows[i]*d[2], d3, na.rm=na.rm)
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }
                        pbClose(pb)
                        x <- readStop(x)
                        return( writeStop(out) )

                }
        }
)
.sum <- function(x, add=NULL, na.rm=FALSE){
        if (as.integer(R.Version()$minor) < 15) {
                old <- TRUE
        } else {
                old <- FALSE
        }
        out <- raster(x)
        d <- dim(x)
        nc <- ncell(out)
        if (is.null(add)) {     
                if (canProcessInMemory(x)) {
                        if (old) {
                                return(  setValues(out, rowSums(getValues(x), na.rm=na.rm)) )
                        } else {
                                return(  setValues(out, .rowSums(getValues(x), nc, d[3], na.rm=na.rm)) )
                        }
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='sum')
                out <- writeStart(out, filename=)
                x <- readStart(x)               

                if (old) {
                        for (i in 1:tr$n) {
                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                v <- rowSums(v, na.rm=na.rm)
                                out <- writeValues(out, v, tr$row[i])
                                pbStep(pb, i)
                        }               
                } else {
                        for (i in 1:tr$n) {
                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                v <- .rowSums(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm)
                                out <- writeValues(out, v, tr$row[i])
                                pbStep(pb, i)
                        }
                }
                pbClose(pb)
                x <- readStop(x)                
                return ( writeStop(out) )



        } else {
                add <- sum(add, na.rm=na.rm)
                d3 <- d[3] + 1

                if (canProcessInMemory(x)) {
                        if (old) {
                                return( setValues(out, rowSums(cbind(getValues(x), add), na.rm=na.rm)) )
                        } else {
                                return( setValues(out, .rowSums(cbind(getValues(x), add), nc, d3, na.rm=na.rm)) )
                        }
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='sum')
                out <- writeStart(out, filename=)
                x <- readStart(x)               
                if (old) {
                        for (i in 1:tr$n) {
                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                v <- rowSums(cbind(v, add), na.rm=na.rm)
                                out <- writeValues(out, v, tr$row[i])
                                pbStep(pb, i)
                        }
                } else {
                        for (i in 1:tr$n) {
                                v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                                v <- .rowSums(cbind(v, add), tr$nrows[i]*d[2], d3, na.rm=na.rm)
                                out <- writeValues(out, v, tr$row[i])
                                pbStep(pb, i)
                        }
                }
                pbClose(pb)
                x <- readStop(x)
                writeStop(out)

        }
}
.min <- function(x, add=NULL, na.rm=FALSE) {
        out <- raster(x)
        if (is.null(add)) {
                if (canProcessInMemory(x)) {
                        return(  setValues(out, .rowMin(getValues(x), na.rm=na.rm)) )
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='min')
                out <- writeStart(out, filename=)
                #x <- readStart(x)
                for (i in 1:tr$n) {
                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                        v <- .rowMin(v, na.rm=na.rm)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                #x <- readStop(x)
                return ( writeStop(out) )

        } else {        
                add <- min(add, na.rm=na.rm)
                if (canProcessInMemory(x)) {
                        x <- setValues(out, .rowMin(cbind(getValues(x), add), na.rm=na.rm))
                        return(x)
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='min')
                out <- writeStart(out, filename=)
                x <- readStart(x)
                for (i in 1:tr$n) {
                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                        v <- .rowMin(cbind(v, add), na.rm=na.rm)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                x <- readStop(x)
                return ( writeStop(out) )

        }

}
.max <- function(x, add=NULL, na.rm=FALSE){
        out <- raster(x)

        if (is.null(add)) {
                if (canProcessInMemory(x)) {
                        return(  setValues(out, .rowMax(getValues(x), na.rm=na.rm)) )
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='max')
                out <- writeStart(out, filename=)
                x <- readStart(x)
                for (i in 1:tr$n) {
                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                        v <- .rowMax( v, na.rm=na.rm)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                x <- readStop(x)
                return( writeStop(out) )

        } else {
                add <- max(add, na.rm=na.rm)

                if (canProcessInMemory(x)) {
                        x <- setValues(out, .rowMax(cbind(getValues(x), add), na.rm=na.rm))
                        return(x)
                }
                tr <- blockSize(x)
                pb <- pbCreate(tr$n, label='max')
                out <- writeStart(out, filename=)
                x <- readStart(x)
                for (i in 1:tr$n) {
                        v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] )
                        v <- .rowMax( cbind(v, add), na.rm=na.rm)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                x <- readStop(x)
                return( writeStop(out) )
        }
}

155 merge.R

# Author: Robert J. Hijmans
# Date : October 2008
# Version 0.9
# Licence GPL v3
# redesinged for multiple row processing
# and arguments ext and overlap
# October 2011
# version 1
if (!isGeneric(merge)) {
        setGeneric(merge, function(x, y, ...)
                standardGeneric(merge))
}       
setMethod('merge', signature(x='Extent', y='ANY'), 
        function(x, y, ...) {
                x <- c(x, y, list(...)) 
                x <- sapply(x, extent)
                x <- x[sapply(x, function(x) inherits(x, 'Extent'))]
                x <- lapply(x, function(e) t(bbox(e)))
                x <- do.call(rbind, x)
                x <- apply(x, 2, range)
                extent(as.vector(x))
        }
)
setMethod('merge', signature(x='RasterStackBrick', y='missing'), 
        function(x, ..., tolerance=0.05, filename=, ext=NULL) {
                nl <- nlayers(x)
                if (nl < 2) {
                        return(x)
                } else if (nl == 2) {
                        merge(x[[1]], x[[2]], tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext)
                } else {
                        do.call(merge, c(x=x[[1]], y=x[[2]], .makeRasterList(x[[3:nl]]), tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext))
                }
        }
)
setMethod('merge', signature(x='Raster', y='Raster'), 
function(x, y, ..., tolerance=0.05, filename=, overlap=TRUE, ext=NULL) { 
        x <- c(x, y, list(...))
        isRast <- sapply(x, function(x) inherits(x, 'Raster'))
        dotargs <- x[ !isRast ]
        x <- x[ isRast ]
        compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance)

        if (is.null(dotargs$datatype)) {
                dotargs$datatype <- .commonDataType(sapply(x, dataType))  
        }
        filename <- trim(filename)
        dotargs$filename <- filename

        nl <- max(unique(sapply(x, nlayers)))
        bb <- .unionExtent(x)
        if (nl > 1) {
                out <- brick(x[[1]], values=FALSE, nl=nl)
        } else {
                out <- raster(x[[1]])
        }
        out <- setExtent(out, bb, keepres=TRUE, snap=FALSE)
        hasV <- sapply(x, hasValues)
        if (!any(hasV)) {
                return(out)
        }
        if (!is.null(ext)) {
                ext <- extent(ext)
                out1 <- extend(out, union(ext, extent(out)))
                out1 <- crop(out1, ext)
                test <- try( intersect(extent(out), extent(out1)) )
                if (class(test) == 'try-error') {
                        stop('ext does not overlap with any of the input data')
                } 
                out <- out1
                ext <- extent(out)      
        }



        if ( canProcessInMemory(out, 3) ) {

                if (!is.null(ext)) {

                        if (overlap) {

                                if (nl > 1) {
                                        v <- matrix(NA, nrow=ncell(out), ncol=nl)
                                        for (i in 1:length(x)) {
                                                xy1 <- xyFromCell(x[[i]], 1)
                                                xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) 
                                                if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) {                
                                                        cells <- cellsFromExtent( out, extent(x[[i]]) )
                                                        vv <- v[cells, ]
                                                        dat <- extract(x[[i]], ext)
                                                        if (!is.matrix(dat)) {
                                                                dat <- matrix(dat, ncol=1)
                                                        }
                                                        na <- ! rowSums(dat)==nl 
                                                        vv[na, ] <- dat[na, ]
                                                        v[cells, ] <- vv
                                                }
                                        }
                                } else {
                                        v <- rep(NA, ncell(out))
                                        for (i in length(x):1) {
                                                xy1 <- xyFromCell(x[[i]], 1)
                                                xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) 
                                                if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) {                
                                                        cells <- cellsFromExtent( out, extent(x[[i]]) )
                                                        xy <- xyFromCell(out, cells)
                                                        d <- extract(x[[i]], xy)
                                                        j <- !is.na(d)
                                                        v[cells[j]] <- d[j]
                                                }
                                        }
                                }
                                out <- setValues(out, v)
                                if (filename != '') {
                                        dotargs$x <- out
                                        out <- do.call(writeRaster, dotargs)
                                }
                                return(out)

                        } else {  # ignore overlap (if any)

                                v <- matrix(NA, nrow=ncell(out), ncol=nl)
                                for (i in length(x):1 ) {
                                        xy1 <- xyFromCell(x[[i]], 1)
                                        xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) 
                                        if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) {                
                                                cells <- cellsFromExtent( out, extent(x[[i]]) )
                                                v[cells, ] <- extract(x[[i]], ext)
                                        }
                                }
                                out <- setValues(out, v)
                                if (filename != '') {
                                        dotargs$x <- out
                                        out <- do.call(writeRaster, dotargs)
                                }
                                return(out)

                        }

                } else {

                        if (overlap) {

                                if (nl > 1) {
                                        v <- matrix(NA, nrow=ncell(out), ncol=nl)
                                        for (i in 1:length(x)) {
                                                cells <- cellsFromExtent( out, extent(x[[i]]) )
                                                vv <- v[cells, ]
                                                dat <- getValues(x[[i]])
                                                if (!is.matrix(dat)) {
                                                        dat <- matrix(dat, ncol=1)
                                                }
                                                na <- ! rowSums(is.na(dat)) == nl 
                                                vv[na, ] <- dat[na, ]
                                                v[cells, ] <- vv
                                        }
                                } else {
                                        v <- rep(NA, ncell(out))
                                        for (i in 1:length(x)) {
                                                cells <- cellsFromExtent( out, extent(x[[i]]) )
                                                vv <- v[cells]
                                                vv[is.na(vv)] <- getValues(x[[i]])[is.na(vv)]
                                                v[cells] <- vv
                                        }
                                }
                                rm(vv)
                                out <- setValues(out, v)
                                if (filename != '') {
                                        dotargs$x <- out
                                        out <- do.call(writeRaster, dotargs)
                                }
                                return(out)

                        } else { # no overlap (or ignore overlap)

                                v <- matrix(NA, nrow=ncell(out), ncol=nl)
                                for (i in length(x):1) {
                                        cells <- cellsFromExtent( out, extent(x[[i]]) )
                                        v[cells, ] <- getValues(x[[i]])
                                }
                                out <- setValues(out, v)
                                if (filename != '') {
                                        dotargs$x <- out
                                        out <- do.call(writeRaster, dotargs)
                                }
                                return(out)
                        }
                }
        }

        if (is.null(ext)) {

                rowcol <- matrix(NA, ncol=6, nrow=length(x))
                for (i in 1:length(x)) {
                        xy1 <- xyFromCell(x[[i]], 1)                            # first row/col on old raster[[i]]
                        xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) )   # last row/col on old raster[[i]]
                        rowcol[i,1] <- rowFromY(out, xy1[2])            # start row on new raster
                        rowcol[i,2] <- rowFromY(out, xy2[2])            # end row
                        rowcol[i,3] <- colFromX(out, xy1[1])        # start col
                        rowcol[i,4] <- colFromX(out, xy2[1])            # end col
                        rowcol[i,5] <- i                                                        # layer
                        rowcol[i,6] <- nrow(x[[i]])
                }
                tr <- blockSize(out)
        #       tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1)))
        #       tr$row <- subset(tr$row, tr$row <= nrow(out)) 
        #       tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row)
        #       tr$n <- length(tr$row)
                pb <- pbCreate(tr$n, dotargs$progress, label='merge')
                dotargs$x <- out
                out <- do.call(writeStart, dotargs)

                if (overlap) {

                        if (nl == 1) {

                                for (i in 1:tr$n) {
                                        v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out))
                                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                        if (nrow(rc) > 0) {
                                                vv <- v
                                                for (j in nrow(rc):1) {  #reverse order so that the first raster covers the second etc.
                                                        vv[] <- NA

                                                        r1 <- tr$row[i]-rc[j,1]+1 
                                                        r2 <- r1 + tr$nrow[i]-1
                                                        z1 <- abs(min(1,r1)-1)+1
                                                        r1 <- max(1, r1)
                                                        r2 <- min(rc[j,6], r2)
                                                        nr <- r2 - r1 + 1
                                                        z2 <- z1 + nr - 1

                                                        vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValues(x[[ rc[j,5] ]], r1, nr), nrow=nr, byrow=TRUE)    
                                                        v[!is.na(vv)] <- vv[!is.na(vv)] 
                                                }
                                        }
                                        out <- writeValues(out, as.vector(t(v)), tr$row[i])
                                        pbStep(pb, i)
                                }

                        } else {

                                for (i in 1:tr$n) {
                                        v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl)
                                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                        if (nrow(rc) > 0) {
                                                vv <- v
                                                for (j in nrow(rc):1) { 
                                                        vv[] <- NA
                                                        r1 <- tr$row[i]-rc[j,1]+1 
                                                        r2 <- r1 + tr$nrow[i]-1
                                                        z1 <- abs(min(1,r1)-1)+1
                                                        r1 <- max(1, r1)
                                                        r2 <- min(rc[j,6], r2)
                                                        nr <- r2 - r1 + 1
                                                        z2 <- z1 + nr - 1
                                                        cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                                        vv[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr)                                           
                                                        v[!is.na(vv)] <- vv[!is.na(vv)] 
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }

                } else { # not overlap

                        for (i in 1:tr$n) {
                                v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl)
                                rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                if (nrow(rc) > 0) {
                                        for (j in nrow(rc):1) { 
                                                r1 <- tr$row[i]-rc[j,1]+1 
                                                r2 <- r1 + tr$nrow[i]-1
                                                z1 <- abs(min(1,r1)-1)+1
                                                r1 <- max(1, r1)
                                                r2 <- min(rc[j,6], r2)
                                                nr <- r2 - r1 + 1
                                                z2 <- z1 + nr - 1
                                                cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                                v[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr)                                    
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }
                }

        } else {  # ext is not null

                rowcol <- matrix(NA, ncol=10, nrow=length(x))
                for (i in 1:length(x)) {
                        xy1 <- xyFromCell(x[[i]], 1)                            # first row/col on old raster[[i]]
                        xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) )   # last row/col on old raster[[i]]
                        xyout1 <- xyFromCell(out, 1)
                        xyout2 <- xyFromCell(out, ncell(out))

                        if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) {
                                j <- rowFromY(out, xy1[2])
                                rowcol[i,1] <- ifelse(is.na(j), 1, j)    # start row on new raster
                                j <- rowFromY(out, xy2[2])
                                rowcol[i,2] <- ifelse(is.na(j), nrow(out), j)    # end row
                                j <- colFromX(out, xy1[1])
                                rowcol[i,3] <- ifelse(is.na(j), 1, j)    # start col
                                j <- colFromX(out, xy2[1])
                                rowcol[i,4] <- ifelse(is.na(j), ncol(out), j)    # end col
                                rowcol[i,5] <- nrow(x[[i]])
                                j <- rowFromY(x[[i]], xyout1[2])
                                rowcol[i,6] <- ifelse(is.na(j), 1, j)
                                j <- rowFromY(x[[i]], xyout2[2])
                                rowcol[i,7] <- ifelse(is.na(j), nrow(x[[i]]), j) - rowcol[i,6] + 1
                                j <- colFromX(x[[i]], xyout1[1])
                                rowcol[i,8] <- ifelse(is.na(j), 1, j)
                                j <- colFromX(x[[i]], xyout2[1])
                                rowcol[i,9] <- ifelse(is.na(j), ncol(x[[i]]), j) - rowcol[i,8] + 1
                                rowcol[i,10] <- i       # layer

                        }
                }
                rowcol <- subset(rowcol, !is.na(rowcol[,1]))
                tr <- blockSize(out)
        #       tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1)))
        #       tr$row <- subset(tr$row, tr$row <= nrow(out)) 
        #       tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row)
        #       tr$n <- length(tr$row)
                pb <- pbCreate(tr$n, dotargs$progress, label='merge')
                dotargs$x <- out
                out <- do.call(writeStart, dotargs)
                if (overlap) {

                        if (nl == 1) {
                                for (i in 1:tr$n) {
                                        v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out))
                                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                        if (nrow(rc) > 0) {
                                                vv <- v
                                                for (j in nrow(rc):1) {  #reverse order so that the first raster covers the second etc.
                                                        vv[] <- NA

                                                        r1 <- tr$row[i]-rc[j,1]+rc[j,6]
                                                        r2 <- r1 + tr$nrow[i]-1
                                                        z1 <- abs(min(1,r1)-1)+1
                                                        r1 <- max(1, r1)
                                                        r2 <- min(rc[j,5], r2)
                                                        nr <- r2 - r1 + 1
                                                        z2 <- z1 + nr - 1

                                                        vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]), nrow=nr, byrow=TRUE)    
                                                        v[!is.na(vv)] <- vv[!is.na(vv)] 
                                                }
                                        }
                                        out <- writeValues(out, as.vector(t(v)), tr$row[i])
                                        pbStep(pb, i)
                                }

                        } else { 

                                for (i in 1:tr$n) {
                                        v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl)
                                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                        if (nrow(rc) > 0) {
                                                vv <- v
                                                for (j in nrow(rc):1) { 
                                                        vv[] <- NA
                                                        r1 <- tr$row[i]-rc[j,1]+rc[j,6]
                                                        r2 <- r1 + tr$nrow[i]-1
                                                        z1 <- abs(min(1,r1)-1)+1
                                                        r1 <- max(1, r1)
                                                        r2 <- min(rc[j,5], r2)
                                                        nr <- r2 - r1 + 1
                                                        z2 <- z1 + nr - 1
                                                        cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                                        vv[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9])                                           
                                                        v[!is.na(vv)] <- vv[!is.na(vv)] 
                                                }
                                        }
                                        out <- writeValues(out, v, tr$row[i])
                                        pbStep(pb, i)
                                }
                        }

                }  else {  # no overlap

                        for (i in 1:tr$n) {
                                v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl)
                                rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                                if (nrow(rc) > 0) {
                                        for (j in nrow(rc):1) { 
                                                r1 <- tr$row[i]-rc[j,1]+rc[j,6]
                                                r2 <- r1 + tr$nrow[i]-1
                                                z1 <- abs(min(1,r1)-1)+1
                                                r1 <- max(1, r1)
                                                r2 <- min(rc[j,5], r2)
                                                nr <- r2 - r1 + 1
                                                z2 <- z1 + nr - 1
                                                cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                                v[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9])                                    
                                        }
                                }
                                out <- writeValues(out, v, tr$row[i])
                                pbStep(pb, i)
                        }
                }
        }
        pbClose(pb)
        writeStop(out)
}
)

156 metadata.R

metadata <- function(x) {
        x@history
}
'metadata<-' <- function(x, value) {
        stopifnot(is.list(value))
        if (is.data.frame(values)) {
                values <- as.list(values)
        }
        if ( any(unlist(sapply(value, function(x)sapply(x, is.list)))) ) {
                stop('invalid metadata: list is nested too deeply')
        }
        nms <- c(names(value), unlist(sapply(value, names)))
        if (is.null(names) | any(nms == '')) {
                stop('invalid metadata: list elements without names')   
        }
        if (any(unlist(sapply(value, is.data.frame)) )) {
                stop('invalid metadata: data.frames are not allowed')   
        }
        type <- rapply(value, class)
        if (any(type == 'matrix')) {
                stop('invalid metadata: matrices are not allowed')
        }
        x@history <- value
        x
}

157 minValue.R

# raster package
# Authors: Robert J. Hijmans
# Date : September 2009
# Version 1.0
# Licence GPL v3
if (!isGeneric(minValue)) {
        setGeneric(minValue, function(x, ...)
                standardGeneric(minValue))
}       
setMethod('minValue', signature(x='RasterLayer'), 
        function(x, layer=-1, warn=TRUE) {
                if ( x@data@haveminmax ) {
                        v <- x@data@min
                        if (isTRUE( v == Inf)) {
                                v <- NA
                        } else {
                                if (! inMemory(x) ) {
                                        v <- v * x@data@gain + x@data@offset
                                }
                        }
                        return(v)
                } else {
                        if (warn) warning('min value not known, use setMinMax')
                        return(NA)
                }
        }
)
setMethod('minValue', signature(x='RasterBrick'), 
        function(x, layer=-1, warn=FALSE) {
                layer <- round(layer)[1]
                if (layer < 1) { 
                        if ( x@data@haveminmax ) {
                                v <- x@data@min
                                v[v == Inf] <- NA
                                if (! inMemory(x) ) {
                                        v <- v * x@data@gain + x@data@offset
                                }       
                                return(v)
                        } else {
                                warning('min value not known, use setMinMax')
                                return(rep(NA, nlayers(x)))
                        }
                } else {
                        if ( x@data@haveminmax ) {
                                v <- x@data@min[layer] * x@data@gain + x@data@offset
                                v[v == Inf] <- NA
                                return(v)
                        } else {
                                warning('min value not known, use setMinMax')
                                return(NA)
                        }
                }
        }
)
setMethod('minValue', signature(x='RasterStack'), 
        function(x, layer=-1, warn=FALSE) {
                layer <- round(layer)[1]
                nl <- nlayers(x)
                if (layer < 1) { 
                        v <- vector(length=nl)
                        for (i in 1:nl) {
                                v[i] <- minValue(x@layers[[i]], warn=warn)
                        }               
                } else {
                        if (layer <= nl) {
                                v <- minValue(x@layers[[layer]])
                        } else {
                                stop('incorrect layer number')
                        }
                }
                return(v)
        }
)
if (!isGeneric(maxValue)) {
        setGeneric(maxValue, function(x, ...)
                standardGeneric(maxValue))
}       
setMethod('maxValue', signature(x='RasterLayer'), 
        function(x, layer=-1, warn=TRUE) {
                if ( x@data@haveminmax ) {
                        v <- x@data@max
                        if (isTRUE( v == -Inf)) {
                                v <- NA
                        } else {
                                if (! inMemory(x) ) {
                                        v <- v * x@data@gain + x@data@offset
                                }
                        }
                        return(v)

                } else {
                        if (warn) warning('max value not known, use setMinMax')
                        return(NA)
                }
        }
)
setMethod('maxValue', signature(x='RasterBrick'), 
        function(x, layer=-1, warn=FALSE) {

                if ( x@data@haveminmax ) {
                        v <- x@data@max
                        v[!is.finite(v)] <- NA
                        if (! inMemory(x) ) {
                                v <- v * x@data@gain + x@data@offset
                        }       
                        return(v)
                } else {
                        if (warn) warning('max value not known, use setMinMax')
                        v <- rep(NA, nlayers(x))
                }
                layer <- round(layer)[1]
                if (layer > 0) {
                        if (layer <= nlayers(x)) {
                                v <- v[layer]
                        } else {
                                stop('invalid layer selected')
                        }
                }
                return(v)
        }
)

setMethod('maxValue', signature(x='RasterStack'), 
        function(x, layer=-1, warn=FALSE) {
                layer <- round(layer)[1]
                nl <- nlayers(x)
                if (layer < 1) { 
                        v <- vector(length=nl)
                        for (i in 1:nl) {
                                v[i] <- maxValue(x@layers[[i]], warn=warn)
                        }               
                } else {
                        if (layer <= nl) {
                                v <- maxValue(x@layers[[layer]])
                        } else {
                                stop('incorrect layer number')
                        }
                }
                return(v)
        }
)

158 modal.R

# Author: Robert J. Hijmans 
# Date :  October 2008
# revised: October 2011
# Version 0.9
# Licence GPL v3
setGeneric(modal, function(x, ...)
        standardGeneric(modal))

setMethod('modal', signature(x='ANY'), 
function(x, ..., ties='random', na.rm=FALSE, freq=FALSE) {
#partly based on http://wiki.r-project.org/rwiki/doku.php?id=tips:stats-basic:modalvalue
        x <- c(x, ...)
        z <- x[!is.na(x)]

        if (freq) {

                if (length(z) == 0) { 
                        return(NA) 
                } else if (!na.rm & length(z) < length(x)) { 
                        return(NA)       
                } else if (length(z) == 1) {
                        return(1)
                } else {
                        return(max( table(z) ))
                }
        }  # else ....

        if (!ties %in% c('lowest', 'highest', 'NA', 'random')) {
                stop(the value of 'ties' should be 'lowest', 'highest', 'NA', or 'random')
        }

        if (length(z) == 0) { 
                return(NA) 
        } else if (!na.rm & length(z) < length(x)) { 
                return(NA)       
        } else if (length(z) == 1) {
                return(z)
        } else {
                freq <- table(z)
                if (is.numeric(z)){
                        w <- as.numeric(names(freq[max(freq)==freq]))           
                } else if (is.logical(z)) {
                        w <- as.logical(freq[max(freq)==freq])
                } else {
                        w <- names(freq[max(freq)==freq])
                }
                if (length(w) > 1) {
                        if (ties == 'lowest') {
                                w <- min(w)
                                if (is.logical(z)) { 
                                        w <- as.logical(w) 
                                }
                        } else if (ties == 'highest') {
                                w <- max(w)
                                if (is.logical(z)) {
                                        w <- as.logical(w) 
                                }
                        } else if (ties == 'NA') {
                                w <- NA
                        } else { # random
                                r <- runif(length(w))
                                w <- w[which.max(r)]
                        }       
                } 
                return(w)
        }       
}
)

159 modalRaster.R

# Author: Robert J. Hijmans 
# Date :  October 2008
# revised: October 2011
# Version 1.0
# Licence GPL v3
setMethod(modal, signature(x='Raster'),
        function(x, ..., ties='random', na.rm=FALSE, freq=FALSE){
                dots <- list(...)
                if (length(dots) > 0) {
                        x <- stack(.makeRasterList(x, ...))
                        add <- .addArgs(...)
                } else {
                        add <- NULL
                }

                nl <- nlayers(x)
                if (nl < 2) {
                        stop('there is not much point in computing a modal value for a single layer')
                } else if (nl == 2) {
                        warning('running modal with only two layers!')
                }

                out <- raster(x)

                if (canProcessInMemory(x)) {
                        x <- cbind(getValues(x), add)
                        x <- setValues(out, apply(x, 1, modal, ties=ties, na.rm=na.rm, freq=freq))
                        return(x)
                }
                tr <- blockSize(out)
                pb <- pbCreate(tr$n, label='modal')
                out <- writeStart(out, filename=)
                for (i in 1:tr$n) {
                        v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add)
                        v <- apply(v, 1, modal, ties=ties, na.rm=na.rm, freq=freq)
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
                pbClose(pb)
                writeStop(out)
        }
)

160 moran.R

# Author: Robert J. Hijmans
# Date : April 2011
# Version 1.0
# Licence GPL v3
..moran <- function(x, directions=8) {
        stopifnot(directions %in% c(4,8))
        # not memory safe       
        adj <- adjacent(x, 1:ncell(x), target=1:ncell(x), directions=8, pairs=TRUE)
        z <- x - cellStats(x, mean)
        wZiZj <- na.omit(z[adj[,1]] * z[adj[,2]])
        z2 <- cellStats(z*z, sum)
        NS0 <- (ncell(z)-cellStats(z, 'countNA')) / length(wZiZj)
        mI <- NS0 * sum(wZiZj) / z2
        return(mI)
}
Moran <- function(x, w=matrix(1,3,3) ) {
        z <- x - cellStats(x, mean)
        wZiZj <- focal(z, w=w, fun='sum', na.rm=TRUE, pad=TRUE)
        wZiZj <- overlay(wZiZj, z, fun=function(x,y){ x * y })
        wZiZj <- cellStats(wZiZj, sum)
        z2 <- cellStats(z*z, sum)
        n <- ncell(z) - cellStats(z, 'countNA')
        # weights
        if (sum(! unique(w) %in% 0:1) > 0) {
                zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1))
                W <- focal( zz, w=w, fun='sum', na.rm=TRUE, pad=TRUE) 
        } else {
                w2 <- w
                w2[w2==0] <- NA
                W <- focal( z, w=w2, fun=function(x, ...){  as.double(sum(!is.na(x))) }, pad=TRUE)              
        }
        NS0 <- n / cellStats(W, sum)
        mI <- NS0 * wZiZj / z2
        return(mI)
}
MoranLocal <- function(x, w=matrix(1,3,3)) { 

        z  <- x - cellStats(x, mean) 
        #weights
        #w <- .getFilter(w)
        if (sum(! unique(w) %in% 0:1) > 0) {
                zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1))
                W  <- focal( zz, w=w, na.rm=TRUE, pad=TRUE)             
        } else {
                w2 <- w
                w2[w2==0] <- NA
                W  <- focal( z, w=w2, fun=function(x, ...){ sum(!is.na(x)) }, na.rm=TRUE, pad=TRUE)
        }
        lz <- focal(z, w=w, na.rm=TRUE, pad=TRUE) / W

        n <- ncell(x) - cellStats(x, 'countNA')
        s2 <-  cellStats(x, sd)^2 
        # adjust variance denominator from n-1 to n 
        s2 <- (s2 * (n-1)) / n 
        (z / s2) * lz
}

161 mosaic.R

# Author: Robert J. Hijmans
# Date : October 2008
# Version 0.9
# Licence GPL v3
# redesigned for multiple row processing
# October 2011
# version 1
if (!isGeneric(mosaic)) {
        setGeneric(mosaic, function(x, y, ...)
                standardGeneric(mosaic))
}       
setMethod('mosaic', signature(x='Raster', y='Raster'), 
function(x, y, ..., fun, tolerance=0.05, filename=) { 
        x <- c(x, y, list(...)) 
        isRast <- sapply(x, function(x) inherits(x, 'Raster'))
        dotargs <- x[ !isRast ]
        x <- x[ isRast ]

        if (is.null(dotargs$datatype)) {
                dotargs$datatype <- .commonDataType(sapply(x, dataType))  
        }
        filename <- trim(filename)
        dotargs$filename <- filename
        nl <- max(unique(sapply(x, nlayers)))
        compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance)
        bb <- .unionExtent(x)
        if (nl > 1) {
                out <- brick(x[[1]], values=FALSE, nl=nl)
        } else {
                out <- raster(x[[1]])
        }

        out <- setExtent(out, bb, keepres=TRUE, snap=FALSE)
        fun <- .makeTextFun(fun)
        if (class(fun) == 'character') { 
                rowcalc <- TRUE 
                fun <- .getRowFun(fun)
        } else { 
                rowcalc <- FALSE 
        }

        if ( canProcessInMemory(out, 2 + length(x)) ) {
                if (nl > 1) {
                        v <- matrix(NA, nrow=ncell(out)*nl, ncol=length(x))
                        for (i in 1:length(x)) {
                                cells <- cellsFromExtent( out, extent(x[[i]]) )
                                cells <- cells + rep(0:(nl-1)*ncell(out), each=length(cells))
                                v[cells, i] <- as.vector(getValues(x[[i]]))
                        }
                        if (rowcalc) {
                                v <- fun(v, na.rm=TRUE)
                        } else {
                                v <- apply(v, 1, fun, na.rm=TRUE)
                        }
                        v <- matrix(v, ncol=nl) 

                } else {

                        v <- matrix(NA, nrow=ncell(out), ncol=length(x))
                        for (i in 1:length(x)) {
                                cells <- cellsFromExtent( out, extent(x[[i]]) )
                                v[cells,i] <- getValues(x[[i]])
                        }
                        if (rowcalc) {
                                v <- fun(v, na.rm=TRUE)
                        } else {
                                v <- apply(v, 1, fun, na.rm=TRUE)
                        }
                }
                out <- setValues(out, v)
                if (filename != '') {
                        dotargs$x <- out
                        out <- do.call(writeRaster, dotargs)
                }
                return(out)
        }
        rowcol <- matrix(NA, ncol=6, nrow=length(x))
        for (i in 1:length(x)) {
                xy1 <- xyFromCell(x[[i]], 1)                            # first row/col on old raster[[i]]
                xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) )   # last row/col on old raster[[i]]
                rowcol[i,1] <- rowFromY(out, xy1[2])            # start row on new raster
                rowcol[i,2] <- rowFromY(out, xy2[2])            # end row
                rowcol[i,3] <- colFromX(out, xy1[1])        # start col
                rowcol[i,4] <- colFromX(out, xy2[1])            # end col
                rowcol[i,5] <- i                                                        # layer
                rowcol[i,6] <- nrow(x[[i]])
        }
        tr <- blockSize(out)
        pb <- pbCreate(tr$n, dotargs$progress, label='mosaic')
        dotargs$x <- out
        out <- do.call(writeStart, dotargs)
        if (nl == 1) {
                for (i in 1:tr$n) {
                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                        if (nrow(rc) > 0) {
                                v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nrow(rc))
                                for (j in 1:nrow(rc)) {

                                        r1 <- tr$row[i]-rc[j,1]+1 
                                        r2 <- r1 + tr$nrow[i]-1
                                        z1 <- abs(min(1,r1)-1)+1
                                        r1 <- max(1, r1)
                                        r2 <- min(rc[j,6], r2)
                                        nr <- r2 - r1 + 1
                                        z2 <- z1 + nr - 1

                                        cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                        v[cells, j] <- getValues(x[[ rc[j,5] ]], r1, nr)
                                }
                                if (rowcalc) {
                                        v <- fun(v, na.rm=TRUE)
                                } else {
                                        v <- apply(v, 1, fun, na.rm=TRUE)
                                }                               
                        } else {
                                v <- rep(NA, tr$nrow[i] * ncol(out))
                        }
                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
        } else {
                for (i in 1:tr$n) {
                        rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] &  tr$row[i] < rowcol[,2])
                        if (nrow(rc) > 0) {
                                v <- matrix(NA, nrow=tr$nrow[i]*ncol(out) * nl, ncol=nrow(rc))
                                for (j in 1:nrow(rc)) { 
                                        r1 <- tr$row[i]-rc[j,1]+1 
                                        r2 <- r1 + tr$nrow[i]-1
                                        z1 <- abs(min(1,r1)-1)+1
                                        r1 <- max(1, r1)
                                        r2 <- min(rc[j,6], r2)
                                        nr <- r2 - r1 + 1
                                        z2 <- z1 + nr - 1
                                        cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4])
                                        cells <- cells + rep(0:(nl-1)* tr$nrow[i]*ncol(out), each=length(cells))
                                        v[cells, j] <- as.vector( getValues(x[[ rc[j,5] ]], r1, nr) )

                                }
                                if (rowcalc) {
                                        v <- fun(v, na.rm=TRUE)
                                } else {
                                        v <- apply(v, 1, fun, na.rm=TRUE)
                                }
                                v <- matrix(v, ncol=nl)
                        } else {
                                v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nl)
                        }

                        out <- writeValues(out, v, tr$row[i])
                        pbStep(pb, i)
                }
        }
        pbClose(pb)
        writeStop(out)
}
)

162 movingFun.R

# Author: Robert Hijmans
# November 2009
# License GPL3
# First versions were based on the rollFun function implemented by Diethelm Wuertz in the 
# fTrading package # Version: 2100.76 # Published:      2009-09-29
movingFun <- function(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE)  { 
        n <- round(abs(n))
    if (n == 0) { stop('n == 0')  }
    x = as.vector(x)
        lng <- length(x)
        if (type == 'around') {
                hn <- floor(n/2)
                if (circular) { x <- c(x[(lng-hn+1):lng], x, x[1:hn])
                } else { x <- c(rep(NA, hn), x, rep(NA, hn)) }
        } else if (type == 'to') {
                if (circular) { x <- c(x[(lng-n+2):lng], x)
                } else { x <- c(rep(NA, n-1), x) }
        } else if (type == 'from') {
                if (circular) { x <- c(x,  x[1:n])
                } else { x <- c(x, rep(NA, n))  }
        } else {
                stop('unknown type; should be around, to, or from')
        }
        m <- matrix(ncol=n, nrow=lng)
    for (i in 1:n) { m[,i] <- x[i:(lng+i-1)] }
    apply(m, MARGIN=1, FUN=fun, na.rm=na.rm)
}

163 multiCore.R

# Author: Matteo Mattiuzzi and Robert J. Hijmans
# Date : November 2010
# Version 1.0
# Licence GPL v3
beginCluster <- function(n, type='SOCK', nice, exclude=NULL) {
        if (! require(snow) ) {
                stop('you need to install the snow package')
        }
        if (exists('raster_Cluster_raster_Cluster', envir=.GlobalEnv)) {
                endCluster()
        }
        if (missing(n)) {
                n <- .detectCores()
                cat(n, 'cores detected\n')
        }
#       if (missing(type)) {
#               type <- getClusterOption(type)
#               cat('cluster type:', type, '\n')
#       }

        cl <- snow::makeCluster(n, type) 
        cl <- .addPackages(cl, exclude=exclude)
        options(rasterClusterObject = cl)
        options(rasterClusterCores = length(cl))
        options(rasterCluster = TRUE)
        options(rasterClusterExclude = exclude)


        if (!missing(nice)){ 
        if (.Platform$OS.type == 'unix') { 
            cmd <- paste(renice,nice,-p)
            foo <- function() system(paste(cmd, Sys.getpid()))
            snow::clusterCall(cl,foo) 
        } else { 
            warning(argument 'nice' only supported on UNIX like operating systems) 
        } 
    } 

}
endCluster <- function() {
        options(rasterCluster = FALSE)
        cl <- options('rasterClusterObject')[[1]]
        if (! is.null(cl)) {
                snow::stopCluster( cl )
                options(rasterClusterObject = NULL)
        }
}
.doCluster <- function() {
        if ( isTRUE( getOption('rasterCluster')) ) {
                return(TRUE)
        } 
        return(FALSE)
}
getCluster <- function() {
        cl <- getOption('rasterClusterObject')
        if (is.null(cl)) { stop('no cluster available, first use beginCluster') }
        cl <- .addPackages(cl, exclude=c('raster', 'sp', getOption('rasterClusterExclude')))
        options( rasterClusterObject = cl )
        options( rasterCluster = FALSE )
        return(cl)
}
returnCluster <- function() {
        cl <- getOption('rasterClusterObject')
        if (is.null(cl)) { stop('no cluster available') }
        options( rasterCluster = TRUE )
}
.addPackages <- function(cl, exclude=NULL) {
        pkgs <- .packages()
        i <- which( pkgs %in% c(exclude, stats, graphics, grDevices, utils, datasets, methods, base) )
        pkgs <- rev( pkgs[-i] )
        for ( pk in pkgs ) {
                snow::clusterCall(cl, library, pk, character.only=TRUE )
        }
        return(cl)
}

164 names.R

# Author: Robert J. Hijmans
# Date:  October 2008
# Version 0.9
# Licence GPL v3
.uniqueNames <- function(x, sep='.') {
        y <- as.matrix(table(x))
        y <- y[y[,1] > 1, ,drop=F]
        if (nrow(y) > 0) {
                y <- rownames(y)
                for (i in 1:length(y)) {
                        j <- which(x==y[i])
                        x[j] <- paste(x[j], sep, 1:length(j), sep='')
                }
        }
        x
}
.goodNames <- function(ln, prefix='layer') {
        validNames(ln, prefix)
}
validNames <- function(x, prefix='layer') {
        x <- trim(as.character(x))
        x[is.na(x)] <- 
        if (.standardnames()) {
                x[x==''] <- prefix
                x <- make.names(x, unique=FALSE)
        }
        .uniqueNames(x)
}
setMethod('labels', signature(object='Raster'), 
        function(object) { 
                names(object)
        }
)

setMethod('names', signature(x='Raster'), 
        function(x) { 
                if (.hasSlot(x@data, 'names')) {
                        ln <- x@data@names
                } else {
                        ln <- x@layernames              
                }
                ln <- ln[1:nlayers(x)]
                validNames(as.vector(ln))
        }
)
setMethod('names', signature(x='RasterStack'), 
        function(x) { 
                ln <- sapply(x@layers, function(i) i@data@names)
                ln <- ln[1:nlayers(x)]
                validNames(as.vector(ln))
        }
)
setMethod('names<-', signature(x='Raster'), 
        function(x, value)  {
                nl <- nlayers(x)
                if (is.null(value)) {
                        value <- rep('', nl)
                } else if (length(value) != nl) {
                        stop('incorrect number of layer names')
                }
                value <- validNames(value)

                if (inherits(x, 'RasterStack')){

                        x@layers <- sapply(1:nl, function(i){ 
                                r <- x@layers[[i]]
                                r@data@names <- value[i]
                                r
                        })

                } else {
                        if (.hasSlot(x@data, 'names')) {
                                x@data@names <- value
                        } else {
                                x@layernames <- value           
                        }
                }
                return(x)
        }
)

165 naValue.R

# Author: Robert J. Hijmans
# Date :  June 2008
# Version 1.0
# Licence GPL v3
.naChanged <- function(x) {
        if (.hasSlot(x@file, 'NAchanged')) {
                return(x@file@NAchanged)
        } else {
                return(TRUE)
        }
}
'NAvalue<-' <- function(x, value) {
        if (inherits(x, 'RasterStack')) {
                nl <- nlayers(x)
                if (length(value) == 1) {
                        value <- rep(value[[1]], nl)
                } else {
                        v <- vector(length=nl)
                        v[] <- as.vector(value)
                        value <- v
                }
                for (i in 1:nl) {
                        x@layers[[i]]@file@nodatavalue <- value[i]
                        x@layers[[i]]@file@NAchanged <- TRUE
                }
        } else {
                x@file@nodatavalue <- value[[1]]
                x@file@NAchanged <- TRUE
        }
        return(x)
}
NAvalue <- function(x) {
        if (inherits(x, 'RasterStack')) {
                sapply(x@layers, function(x) { x@file@nodatavalue })
        } else {
                return(x@file@nodatavalue)
        }
}

166 ncell.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  April 2009
# Version 0.9
# Licence GPL v3
if (!isGeneric(ncell)) {
        setGeneric(ncell, function(x)
                standardGeneric(ncell))
}       
setMethod('ncell', signature(x='BasicRaster'), 
        function(x) {
                return(as.numeric(x@ncols) * x@nrows)
        }
)
setMethod('ncell', signature(x='ANY'), 
        function(x) {
                NROW(x) * NCOL(x)
        }
)
setMethod('length', signature(x='BasicRaster'), 
        function(x) {
                ncell(x) * nlayers(x)
        }
)

167 netCDFreadCells.R

# Author: Robert J. Hijmans
# Date: June 2010
# Version 1.0
# Licence GPL v3
.readRasterCellsNetCDF <- function(x, cells) {
# read all
        if (canProcessInMemory(x, 2)) {
                r <- getValues(x)
                r <- r[cells]
                return(r)
        } 

        if (canProcessInMemory(x, 2)) {
        # read only rows needed 
                row1 <- rowFromCell(x, min(cells))
                row2 <- rowFromCell(x, max(cells))
                ncl <- (row2 - row1 + 1) * x@ncols
                r <- raster(nrow=1, ncol=ncl)
                v <- getValues(x, row1, row2-row1+1)
                v <- v[cells-cellFromRowCol(x, row1, 1)+1]
                return(v)
        }

# read row by row
        colrow <- matrix(ncol=3, nrow=length(cells))
        colrow[,1] <- colFromCell(x, cells)
        colrow[,2] <- rowFromCell(x, cells)
        colrow[,3] <- NA
        rows <- sort(unique(colrow[,2]))
        readrows <- rows
        if ( x@file@toptobottom ) { 
                readrows <- x@nrows - readrows + 1      
        }
        zvar = x@data@zvar
        time = x@data@band

        if (isTRUE(getOption('rasterNCDF4'))) {
                nc <- ncdf4::nc_open(x@file@name)
                on.exit( ncdf4::nc_close(nc) )          
                getfun <- ncdf4::ncvar_get

        } else {
                nc <- ncdf::open.ncdf(x@file@name)
                on.exit( ncdf::close.ncdf(nc) )
                getfun <- ncdf::get.var.ncdf
        }

        if (nc$var[[zvar]]$ndims == 1) {
                ncx <- x@ncols
                count <- ncx
                for (i in 1:length(rows)) {
                        start <- (readrows[i]-1) * ncx + 1
                        v <- as.vector(getfun(nc, varid=zvar, start=start, count=count))
                        thisrow <- subset(colrow, colrow[,2] == rows[i])
                        colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]]
                }       
        } else  if (nc$var[[zvar]]$ndims == 2) {
                count <- c(x@ncols, 1)
                for (i in 1:length(rows)) {
                        start <- c(1, readrows[i])
                        v <- as.vector(getfun(nc, varid=zvar, start=start, count=count))
                        thisrow <- subset(colrow, colrow[,2] == rows[i])
                        colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]]
                }       
        } else if (nc$var[[zvar]]$ndims == 3) {
                count <- c(x@ncols, 1, 1)
                for (i in 1:length(rows)) {
                        start <- c(1, readrows[i], time)
                        v <- as.vector(getfun(nc, varid=zvar, start=start, count=count))
                        thisrow <- subset(colrow, colrow[,2] == rows[i])
                        colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]]
                }       
        } else {
                if (x@data@dim3 == 4) {
                        count <- c(x@ncols, 1, 1, 1)
                        for (i in 1:length(rows)) {
                                start <- c(1, readrows[i], x@data@level, time)
                                v <- as.vector(getfun(nc, varid=zvar, start=start, count=count))
                                thisrow <- subset(colrow, colrow[,2] == rows[i])
                                colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]]
                        }
                } else {
                        count <- c(x@ncols, 1, 1, 1)
                        for (i in 1:length(rows)) {
                                start <- c(1, readrows[i], time, x@data@level)
                                v <- as.vector(getfun(nc, varid=zvar, start=start, count=count))
                                thisrow <- subset(colrow, colrow[,2] == rows[i])
                                colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]]
                        }
                }
        }

        colrow <- colrow[,3]
        #if (!is.na(x@file@nodatavalue)) { colrow[colrow==x@file@nodatavalue] <- NA     }
        #colrow <- x@data@add_offset + colrow * x@data@scale_factor
        colrow[colrow == x@file@nodatavalue] <- NA
        return(colrow) 
}
.readBrickCellsNetCDF <- function(x, cells, layer, nl) {
        i <- which(!is.na(cells))


        if (length(cells) > 1000) {
                if (canProcessInMemory(x, 2)) {
# read all
                        endlayer <- layer+nl-1
                        r <- getValues(x)
                        r <- r[cells, layer:endlayer]
                        return(r)
                }
        } 

# read cell by cell
        zvar <- x@data@zvar
        dim3 <- x@data@dim3
        cols <- colFromCell(x, cells)
        rows <- rowFromCell(x, cells)
        if ( x@file@toptobottom ) { 
                rows <- x@nrows - rows + 1 
        }

        if (getOption('rasterNCDF4')) {
                nc <- ncdf4::nc_open(x@file@name)
                on.exit( ncdf4::nc_close(nc) )          
                getfun <- ncdf4::ncvar_get

        } else {
                nc <- ncdf::open.ncdf(x@file@name)
                on.exit( ncdf::close.ncdf(nc) )
                getfun <- ncdf::get.var.ncdf
        }


        # this needs to be optimized. Read chunks and extract cells
        j <- which(!is.na(cells))
        if (nc$var[[zvar]]$ndims == 2) {
                count <- c(1, 1)
                res <- matrix(NA, nrow=length(cells), ncol=1)
                for (i in j) {
                        start <- c(cols[i], rows[i])
                        res[i] <- getfun(nc, varid=zvar, start=start, count=count)
                }       
        } else if (nc$var[[zvar]]$ndims == 3) {
                count <- c(1, 1, nl)
                res <- matrix(NA, nrow=length(cells), ncol=nl)
                for (i in j) {
                        start <- c(cols[i], rows[i], layer)
                        res[i,] <- getfun(nc, varid=zvar, start=start, count=count)
                }       
        } else {
                if (x@data@dim3 == 4) {
                        count <- c(1, 1, 1, nl)
                        res <- matrix(NA, nrow=length(cells), ncol=nl)
                        for (i in j) {
                                start <- c(cols[i], rows[i], x@data@level, layer)
                                res[i,] <- getfun(nc, varid=zvar, start=start, count=count)
                        }       
                } else {
                        count <- c(1, 1, nl, 1)
                        res <- matrix(nrow=length(cells), ncol=nl)
                        for (i in 1:length(cells)) {
                                start <- c(cols[i], rows[i], layer, 1)
                                res[i,] <- getfun(nc, varid=zvar, start=start, count=count)
                        }       
                }
        }
        #if (!is.na(x@file@nodatavalue)) { res[res==x@file@nodatavalue] <- NA   }
        #res <- x@data@add_offset + res * x@data@scale_factor
        res[res == x@file@nodatavalue] <- NA
        return(res) 
}

168 netCDFread.R

# Author: Robert J. Hijmans
# Date: June 2010
# Version 1.0
# Licence GPL v3
.readRowsNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1)) {
        if ( x@file@toptobottom ) { 
                row <- x@nrows - row - nrows + 2 
        }
        is.open <- x@file@open
        if (isTRUE(getOption('rasterNCDF4'))) {
                if (is.open) {
                        nc <- x@file@con
                } else {
                        nc <- ncdf4::nc_open(x@file@name)
                        on.exit( ncdf4::nc_close(nc) )          
                }
                ncdf4 <- TRUE   

        } else {
                if (is.open) {
                        nc <- x@file@con
                } else {
                        nc <- ncdf::open.ncdf(x@file@name)
                        on.exit( ncdf::close.ncdf(nc) )
                }       
                ncdf4 <- FALSE
        }

        zvar <- x@data@zvar
        if (nc$var[[zvar]]$ndims == 1) {
                # for GMT
                ncx <- ncol(x)
                start <- (row-1) * ncx + 1
                count <- nrows * ncx 
                if (ncdf4) {
                        d <- ncdf4::ncvar_get( nc, varid=zvar,  start=start, count=count )              
                } else {
                        d <- ncdf::get.var.ncdf( nc,  varid=zvar,  start=start, count=count )
                }
                if (col > 1 | ncols < ncx) {
                        d <- matrix(d, ncol=ncx, byrow=TRUE)
                        d <- d[, col:(col+ncols-1)]
                        d <- as.vector(t(d))
                }

        } else if (nc$var[[zvar]]$ndims == 2) {
                start <- c(col, row)
                count <- c(ncols, nrows)
                if (ncdf4) {
                        d <- ncdf4::ncvar_get( nc, varid=zvar,  start=start, count=count )              
                } else {
                        d <- ncdf::get.var.ncdf( nc,  varid=zvar,  start=start, count=count )
                }
        } else if (nc$var[[zvar]]$ndims == 3) {
                start <- c(col, row, x@data@band)
                count <- c(ncols, nrows, 1)
                if (ncdf4) {
                        d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)
                } else {
                        d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count)
                }

        } else {
                if (x@data@dim3 == 4) {
                        start <- c(col, row, x@data@level, x@data@band)
                        count <- c(ncols, nrows, 1, 1)
                        if (ncdf4) {
                                d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)
                        } else {
                                d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count)                       
                        }
                } else {
                        start <- c(col, row, x@data@band, x@data@level)
                        count <- c(ncols, nrows, 1, 1)
                        if (ncdf4) {
                                d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)
                        } else {
                                d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count)
                        }
                }
        }

        #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA }
        #d <- x@data@add_offset + d * x@data@scale_factor

        if (length(dim(d)) > 1) {
                if ( x@file@toptobottom ) { 
                        d <- d[, ncol(d):1]     
                }
        }
        d <- as.vector(d) 
        d[d == x@file@nodatavalue] <- NA
        return(d)       
}



.readRowsBrickNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) {
        is.open <- x@file@open

        if ( x@file@toptobottom ) { 
                row <- x@nrows - row - nrows + 2
        }
        navalue <- x@file@nodatavalue


        #n the true number of layers
        #nn the span of layers between the first and the last
        #alyrs, the layers requested, scaled to start at one.
        n <- nn <- nlayers(x)
        if (missing(lyrs)) {
                layer <- 1
                lyrs <- 1:n
        } else {
                lyrs <- lyrs[lyrs %in% 1:n]
                if (length(lyrs) == 0) {
                        stop(no valid layers)
                }
                layer <- lyrs[1]
                n <- length(lyrs)
                nn <- lyrs[length(lyrs)] - lyrs[1] + 1
        }
        alyrs <- lyrs - lyrs[1] + 1
        lns <- names(x)[lyrs]

        nrows <- min(round(nrows), x@nrows-row+1)
        ncols <- min((x@ncols-col+1), ncols)
        stopifnot(nrows > 0)
        stopifnot(ncols > 0)
        if (getOption('rasterNCDF4')) {
                if (is.open) {
                        nc <- x@file@con
                } else {
                        nc <- ncdf4::nc_open(x@file@name)
                        on.exit( ncdf4::nc_close(nc) )          
                }
                ncdf4 <- TRUE

        } else {
                if (is.open) {
                        nc <- x@file@con
                } else {
                        nc <- ncdf::open.ncdf(x@file@name)
                        on.exit( ncdf::close.ncdf(nc) )
                }       
                ncdf4 <- FALSE
        }

        zvar <- x@data@zvar

        if (nc$var[[zvar]]$ndims == 4) {
                if (x@data@dim3 == 4) {
                        start <- c(col, row, x@data@level, layer)
                        count <- c(ncols, nrows, 1, nn)
                } else {
                        start <- c(col, row, layer, x@data@level)
                        count <- c(ncols, nrows, nn, 1)
                }               
        } else {
                start <- c(col, row, layer)
                count <- c(ncols, nrows,  nn)
        }

        if (ncdf4) {
                d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) 
        } else {
                d <- ncdf::get.var.ncdf(nc, varid=zvar, start=start, count=count)
        }

        #if (!is.na(x@file@nodatavalue)) {      d[d==x@file@nodatavalue] <- NA  }
        #d <- x@data@add_offset + d * x@data@scale_factor

        if (nlayers(x) > 1) {
                dims = dim(d)
                if (length(dims) == 3) {
                        if ( x@file@toptobottom ) { 
                                v <- matrix(nrow=nrows*ncols, ncol=n)
                                for (i in 1:length(alyrs)) {
                                        x <- d[,,alyrs[i]]
                                        v[,i] <- as.vector( x[, ncol(x):1] )
                                }
                        } else {
                                dim(d) = c(dims[1] * dims[2], dims[3])
                                d <- d[, alyrs, drop=FALSE]
                                d[d == x@file@nodatavalue] <- NA
                                return(d)
                        }
                } else if (length(dims) == 2) {
                        if (nrows==1) {
                                d <- d[ , alyrs,drop=FALSE]
                                d[d == navalue] <- NA
                                return(d)

                        } else if (n==1) {
                                v <- matrix(nrow=nrows*ncols, ncol=n)
                                if ( x@file@toptobottom ) { 
                                        v[] <- as.vector(d[,ncol(d):1])
                                } else {
                                        v[] <- as.vector(d)                             
                                }

                        } else if (ncols==1) {
                                if ( x@file@toptobottom ) { 
                                        d <- d[nrow(d):1, ]
                                }
                                d <- d[ , alyrs, drop=FALSE]
                                d[d == navalue] <- NA
                                return(d)
                        }
                } else { # length(dims) == 1
                        v <- matrix(nrow=nrows*ncols, ncol=n)
                        if ( x@file@toptobottom & nrows > 1) {
                                d <- rev(d)
                        }

                        v[] <- d # d[, alyrs, drop=FALSE]
                }
        } else {
                if ( x@file@toptobottom ) { 
                        if (is.matrix(d)) {
                                d <- d[, ncol(d):1]
                        }
                } 
                v <- matrix(as.vector(d), ncol=1)
                #v <- v[,lyrs,drop=FALSE]
        }

        v[v == navalue] <- NA
        colnames(v) <- lns
        return(v)
}

169 netCDFtoRasterCD.R

# Author: Robert J. Hijmans
# Date: Aug 2009
# Version 1.0
# Licence GPL v3
# Aug 2012, adapted for use with ncdf4 library 
.doTime <- function(x, nc, zvar, dim3, ncdf4) {
        dodays <- TRUE
        dohours <- FALSE

        un <- nc$var[[zvar]]$dim[[dim3]]$units  
        if (substr(un, 1, 10) == days since) { 
                startDate = as.Date(substr(un, 12, 22))
        } else {
                if (substr(un, 1, 11) == hours since) { 
                        dohours <- TRUE
                }
                dodays <- FALSE
        }
        if (dohours) {
                startTime <- substr(un, 13, 30)
                startTime <- strptime(startTime, %Y-%m-%d %H:%M:%OS)
                time <- startTime + as.numeric(getZ(x)) * 3600
                time <- as.character(time)
                if (!is.na(time[1])) {
                        x@z <- list(time)
                        names(x@z) <- as.character('Date/time')
                }
        } else if (dodays) {
                # cal = nc$var[[zvar]]$dim[[dim3]]$calendar ?
                if (ncdf4) {
                        cal <- ncdf4::ncatt_get(nc, time, calendar)
                } else {
                        cal <- ncdf::att.get.ncdf(nc, time, calendar)           
                }
                if (! cal$hasatt ) {
                        greg <- TRUE
                } else {
                        cal <- cal$value
                        if (cal =='gregorian' | cal =='proleptic_gregorian' | cal=='standard') {
                                greg <- TRUE
                        } else if (cal == 'noleap' | cal == '365 day' | cal == '365_day') { 
                                greg <- FALSE
                                nday <- 365
                        } else if (cal == '360_day') { 
                                greg <- FALSE
                                nday <- 360
                        } else {
                                greg <- TRUE
                                warning('assuming a standard calender:', cal)
                        }
                }
                time <- getZ(x)
                if (greg) {
                        time <- as.Date(time, origin=startDate)
                } else {
                        startyear <-  as.numeric( format(startDate, %Y) )
                        startmonth <- as.numeric( format(startDate, %m) )
                        startday <- as.numeric( format(startDate, %d) )
                        year <- trunc( as.numeric(time)/nday )
                        doy <- (time - (year * nday))
                        origin <- paste(year+startyear, -, startmonth, -, startday, sep='')
                        time <- as.Date(doy, origin=origin)             
                }
                x@z <- list(time)
                names(x@z) <- 'Date'
        }
        return(x)
}
.dimNames <- function(nc) {
        n <- nc$dim
        nams <- vector(length=n)
        if (n > 0) {
                for (i in 1:n) {
                        nams[i] <- nc$dim[[i]]$name
                }
        }
        return(nams)
}
.varName <- function(nc, varname='', warn=TRUE) {
        n <- nc$nvars
        dims <- vars <- vector(length=n)
        if (n > 0) {
                for (i in 1:n) {
                        vars[i] <- nc$var[[i]]$name
                        dims[i] <- nc$var[[i]]$ndims
                }
                vars <- vars[dims > 1]
                dims <- dims[dims > 1]
        }
        if (varname=='') { 
                nv <- length(vars)
                if (nv == 0) {
                        return('z')
                } 

                if (nv  == 1) {
                        varname <- vars
                } else {
                        varname <- vars[which.max(dims)]
                        if (warn) {
                                if (sum(dims == max(dims)) > 1) {
                                        vars <- vars[dims==max(dims)]
                                        warning('varname used is: ', varname, '\nIf that is not correct, you can set it to one of: ', paste(vars, collapse=, ) )
                                }
                        }
                }
        }
        zvar <- which(varname == vars)
        if (length(zvar) == 0) {
                stop('varname: ', varname, ' does not exist in the file. Select one from:\n', paste(vars, collapse=, ) )
        }
        return(varname)
}
.rasterObjectFromCDF <- function(filename, varname='', band=NA, type='RasterLayer', lvar=3, level=0, 
                        warn=TRUE, dims=1:3, crs=NA, stopIfNotEqualSpaced=TRUE, ...) {
        ncdf4 <- .NCDFversion4()

        if (ncdf4) {
                options(rasterNCDF4 = TRUE)
                nc <- ncdf4::nc_open(filename)
                on.exit( ncdf4::nc_close(nc) )          
                conv <- ncdf4::ncatt_get(nc, 0, Conventions)

        } else {
                options(rasterNCDF4 = FALSE)
                nc <- ncdf::open.ncdf(filename)
                on.exit( ncdf::close.ncdf(nc) )         
                conv <- ncdf::att.get.ncdf(nc, 0, Conventions)
        } 


        # assuming CF-1.0

        zvar <- .varName(nc, varname, warn=warn)
        # datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec )
        dim3 <- dims[3]
        ndims <- nc$var[[zvar]]$ndims

        if (ndims== 1) { 

                return(.rasterObjectFromCDF_GMT(nc, ncdf4))

        } else if (ndims == 4) { 
                if (type != 'RasterQuadBrick') {
                        nlevs <- nc$var[[zvar]]$dim[[lvar]]$len
                        if (level <=0 ) {
                                level <- 1
                                if (nlevs > 1) {
                                        warning('level set to 1 (there are ', nlevs, ' levels)')
                                }
                        } else {
                                oldlevel <- level <- round(level)
                                level <- max(1, min(level, nlevs))
                                if (oldlevel != level) {
                                        warning('level set to: ', level)
                                }
                        }
                        if (lvar == 4) { 
                                dim3 <- 3 
                        } else { 
                                dim3 <- 4 
                        }
                }
        } else if (ndims > 4) { 
                warning(zvar, ' has more than 4 dimensions, I do not know what to do with these data')
        }

        ncols <- nc$var[[zvar]]$dim[[dims[1]]]$len
        nrows <- nc$var[[zvar]]$dim[[dims[2]]]$len
        xx <- nc$var[[zvar]]$dim[[dims[1]]]$vals
        rs <- xx[-length(xx)] - xx[-1]
        if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) {
                if (is.na(stopIfNotEqualSpaced)) {
                        warning('cells are not equally spaced; you should extract values as points') 
                } else if (stopIfNotEqualSpaced) {
                        stop('cells are not equally spaced; you should extract values as points') 
                }
        }


        xrange <- c(min(xx), max(xx))
        resx <- (xrange[2] - xrange[1]) / (ncols-1)
        rm(xx)

        yy <- nc$var[[zvar]]$dim[[dims[2]]]$vals
        rs <- yy[-length(yy)] - yy[-1]
        if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) {
                if (is.na(stopIfNotEqualSpaced)) {
                        warning('cells are not equally spaced; you should extract values as points') 
                } else if (stopIfNotEqualSpaced) {
                        stop('cells are not equally spaced; you should extract values as points') 
                }
        }
        yrange <- c(min(yy), max(yy))
        resy <- (yrange[2] - yrange[1]) / (nrows-1)
        if (yy[1] > yy[length(yy)]) { toptobottom  <- FALSE
        } else { toptobottom <- TRUE }
        rm(yy)
        xrange[1] <- xrange[1] - 0.5 * resx
        xrange[2] <- xrange[2] + 0.5 * resx
        yrange[1] <- yrange[1] - 0.5 * resy
        yrange[2] <- yrange[2] + 0.5 * resy

        long_name <- zvar
        unit <- ''

        proj <- NA
        if (ncdf4) {
                a <- ncdf4::ncatt_get(nc, zvar, long_name)
                if (a$hasatt) { long_name <- a$value }
                a <- ncdf4::ncatt_get(nc, zvar, units)
                if (a$hasatt) { unit <- a$value }
                a <- ncdf4::ncatt_get(nc, zvar, grid_mapping)
                if ( a$hasatt ) { 
                        gridmap  <- a$value 
                        atts <- ncdf4::ncatt_get(nc, gridmap)
                        try(proj <- .getCRSfromGridMap4(atts), silent=TRUE)
                } else {
                        a <- ncdf4::ncatt_get(nc, zvar, projection_format)
                        if ( a$hasatt ) { 
                                projection_format  <- a$value 
                                if (isTRUE(projection_format == PROJ.4)) {
                                        a <- ncdf4::ncatt_get(nc, zvar, projection)
                                        if ( a$hasatt ) { 
                                                proj <- a$value 
                                        }
                                }
                        }
                }
                natest <- ncdf4::ncatt_get(nc, zvar, _FillValue)
                natest2 <- ncdf4::ncatt_get(nc, zvar, missing_value)            


        } else {
                a <- ncdf::att.get.ncdf(nc, zvar, long_name)
                if (a$hasatt) { long_name <- a$value }
                a <- ncdf::att.get.ncdf(nc, zvar, units)
                if (a$hasatt) { unit <- a$value }
                a <- ncdf::att.get.ncdf(nc, zvar, grid_mapping)
                if ( a$hasatt ) { 
                        try(proj <- .getCRSfromGridMap3(nc, a$value), silent=TRUE)
                } else {
                        a <- ncdf::att.get.ncdf(nc, zvar, projection)
                        if ( a$hasatt ) { 
                                projection  <- a$value 
                                a <- ncdf::att.get.ncdf(nc, zvar, projection_format)
                                if ( a$hasatt ) { 
                                        projection_format  <- a$value 
                                        if (isTRUE(projection_format == PROJ.4)) {
                                                proj <- projection
                                        }
                                }
                        }
                }
                natest <- ncdf::att.get.ncdf(nc, zvar, _FillValue)
                natest2 <- ncdf::att.get.ncdf(nc, zvar, missing_value)          
        }
        if (is.na(proj)) {
                if (((tolower(substr(nc$var[[zvar]]$dim[[dims[1]]]$name, 1, 3)) == 'lon')  &
                    ( tolower(substr(nc$var[[zvar]]$dim[[dims[2]]]$name, 1, 3)) == 'lat' ) ) | 
                    ( xrange[1] < -181 | xrange[2] > 181 | yrange[1] < -91 | yrange[2] > 91 )) {
                                proj <- '+proj=longlat +datum=WGS84'
                }
        } 


        crs <- .getProj(proj, crs)


        if (type == 'RasterLayer') {
                r <- raster(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs)
                names(r) <- long_name
        } else if (type == 'RasterBrick') {
                r <- brick(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs)
                r@title <- long_name
        } else if (type == 'RasterQuadBrick') {
                r <- .quad(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs)
                r@title <- long_name    
                if (lvar == 4) { 
                        dim3 <- 3 
                        step3 <- 4
                } else { 
                        dim3 <- 4 
                        step3 <- 3
                }
                r@nlevels <- nc$var[[zvar]]$dim[[dim3]]$len
                r@steps  <- nc$var[[zvar]]$dim[[step3]]$len
        }

        r@file@name <- filename
        r@file@toptobottom <- toptobottom
        r@data@unit <- unit


        attr(r@data, zvar) <- zvar
        attr(r@data, dim3) <- dim3
        attr(r@data, level) <- level

        r@file@driver <- netcdf 

        if (natest$hasatt) { 
                r@file@nodatavalue <- as.numeric(natest$value)
        } else if (natest2$hasatt) { 
                r@file@nodatavalue <- as.numeric(natest2$value)
        }
        r@data@fromdisk <- TRUE

        if (ndims == 2) {
                nbands = 1
        } else {
                r@file@nbands <- nc$var[[zvar]]$dim[[dim3]]$len
                r@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals )
                if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) {
                        try( r <- .doTime(r, nc, zvar, dim3, ncdf4) )
                } else {
                        names(r@z) <- nc$var[[zvar]]$dim[[dim3]]$units
                }
        }

        if (type == 'RasterLayer') {
                if (is.null(band) | is.na(band)) {
                        if (ndims > 2) { 
                                stop(zvar, ' has multiple layers, provide a band value between 1 and ', nc$var[[zvar]]$dim[[dim3]]$len)
                        } 
                } else {
                        if (length(band) > 1) {
                                stop('A RasterLayer can only have a single band. You can use a RasterBrick instead')
                        }               
                        if (is.na(band)) {
                                r@data@band <- as.integer(1)
                        } else {
                                band <- as.integer(band)
                                if ( band > nbands(r) ) {
                                        stop(paste(band too high. Should be between 1 and, nbands))
                                } 
                                if ( band < 1) { 
                                        stop(paste(band should be 1 or higher))         
                                }                       
                                r@data@band <- band
                        }
                        r@z <- list( getZ(r)[r@data@band] )
                } 
        } else {
                #if (length(ndims)== 2) { 
                #       stop('cannot make a RasterBrick from data that has only two dimensions (no time step), use raster() instead, and then make a RasterBrick from that')    
                #} 
                r@data@nlayers <- r@file@nbands
                r@data@min <- rep(Inf, r@file@nbands)
                r@data@max <- rep(-Inf, r@file@nbands)
                try( names(r) <- as.character(r@z[[1]]), silent=TRUE )
        }


        return(r)
}

170 netCDFtoRasterGMT.R

# Author: Robert J. Hijmans
# Date: March 2013
# Version 1.0
# Licence GPL v3
.rasterObjectFromCDF_GMT <- function(nc, ncdf4) {
#       ncdf4 <- .NCDFversion4()
        if (ncdf4) {
                options(rasterNCDF4 = TRUE)
#               nc <- ncdf4::nc_open(filename)
#               on.exit( ncdf4::nc_close(nc) )          
        #       conv <- ncdf4::ncatt_get(nc, 0, Conventions)
                dims <- ncdf4::ncvar_get(nc, dimension, 1)
                xr <- ncdf4::ncvar_get(nc, x_range, 1)
                yr <- ncdf4::ncvar_get(nc, y_range, 1)
                zr <- ncdf4::ncvar_get(nc, z_range, 1)
                sp <- ncdf4::ncvar_get(nc, spacing, 1)

        } else {
                options(rasterNCDF4 = FALSE)
#               nc <- ncdf::open.ncdf(filename)
#               on.exit( ncdf::close.ncdf(nc) )         
        #       conv <- ncdf::att.get.ncdf(nc, 0, Conventions)
                dims <- ncdf::get.var.ncdf(nc, dimension, 1)
                xr <- ncdf::get.var.ncdf(nc, x_range, 1)
                yr <- ncdf::get.var.ncdf(nc, y_range, 1)
                zr <- ncdf::get.var.ncdf(nc, z_range, 1)
                sp <- ncdf::get.var.ncdf(nc, spacing, 1)
        } 
        zvar = 'z'
        #datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec )
        #ncell <- nc$var[[zvar]]$dim[[1]]$len
        #stopifnot(prod(dims) == ncell)
        crs <- NA
        if (xr[1] > -181 & xr[2] < 181 & yr[1] > -91 & yr[2] < 91 ) {
                crs <- +proj=longlat +datum=WGS84
        }
        dif1 <- abs(((xr[2] - xr[1]) / dims[1]) - sp[2])
        dif2 <- abs(((xr[2] - xr[1]) / (dims[1]-1)) - sp[2])

        if (dif1 < dif2) {  # 30 sec GEBCO data
                r <- raster(xmn=xr[1], xmx=xr[2], ymn=yr[1], ymx=yr[2], ncol=dims[1], nrow=dims[2], crs=crs)
        } else {  # 1 min data 
                resx <- (xr[2] - xr[1]) / (dims[1]-1)
                resy <- (yr[2] - yr[1]) / (dims[2]-1)
                r <- raster(xmn=xr[1]-(0.5*resx), xmx=xr[2]+(0.5*resx), ymn=yr[1]-(0.5*resy), ymx=yr[2]+(0.5*resy), ncol=dims[1], nrow=dims[2], crs=crs)
        }

        r@file@name <- nc$filename
        r@file@toptobottom <- FALSE
        attr(r@data, zvar) <- zvar
        attr(r@data, dim3) <- 1
        r@file@driver <- netcdf
        r@data@fromdisk <- TRUE
        return(r)
}

171 netCDFtoStack.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date: Sept 2009 / revised June 2010
# Version 1.0
# Licence GPL v3
.stackCDF <- function(filename, varname='', bands='') {
        ncdf4 <- .NCDFversion4()
        if (ncdf4) {
                nc <- ncdf4::nc_open(filename)
                on.exit( ncdf4::nc_close(nc) )          

        } else {
                nc <- ncdf::open.ncdf(filename)
                on.exit( ncdf::close.ncdf(nc) )         
        } 
        zvar <- .varName(nc, varname)
        dims <- nc$var[[zvar]]$ndims    

        dim3 <- 3
        if (dims== 1) { 
                stop('variable only has a single dimension; I cannot make a RasterLayer from this')
        } else if (dims > 3) { 
                dim3 <- dims
                warning(zvar, ' has ', dims, ' dimensions, I am using the last one')
        } else if (dims == 2) {
                return( stack ( raster(filename, varname=zvar )  )  )
        } 

        if (is.null(bands)) { bands <- ''}
        if (bands[1] == '') {
                bands = 1 : nc$var[[zvar]]$dim[[dim3]]$len
        }
        r <- raster(filename, varname=zvar, band=bands[1])
        st <- stack( r )
        st@title <- names(r)
        if (length(bands) > 1) {
                st@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals[bands] )
                names(st@z) <- nc$var[[zvar]]$dim[[dim3]]$units
                if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) {      
                        try( st <- .doTime(st, nc, zvar, dim3, ncdf4)  )
                }
                nms <- as.character(st@z[[1]])
                st@layers <- lapply(bands, function(x){
                                                                                        r@data@band <- x;
                                                                                        r@data@names <- nms[x];
                                                                                        return(r)} 
                                                                                )
        } 
        return( st )
}

 #s = .stackCDF(f, varname='uwnd')

172 netCDFutil.R

# Author: Robert J. Hijmans
# Date: June 2010
# Version 1.0
# Licence GPL v3
.getCRSfromGridMap3 <- function(nc, gridmap) {
        m <- matrix(c(grid_mapping_name, +proj, false_easting, +x_0,false_northing, +y_0, scale_factor_at_projection_origin, +k_0, scale_factor_at_central_meridian, +k_0, standard_parallel, +lat_1, standard_parallel1, +lat_1, standard_parallel2, +lat_2, longitude_of_central_meridian, +lon_0, longitude_of_projection_origin, +lon_0, latitude_of_projection_origin, +lat_0, straight_vertical_longitude_from_pole, +lon_0), ncol=2, byrow=TRUE)
        g <- list()
        for (i in 1:nrow(m)) {
                a <- ncdf::att.get.ncdf(nc, gridmap, m[i,1])
                if (a$hasatt) {
                        lst <- list(a$value)
                        names(lst) <- m[i,1]
                        g <- c(g, lst)
                }
        }
        .getCRSfromGridMap4(g)
}
.getCRSfromGridMap4 <- function(g) {
# based on info at 
# http://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus
# accessed 7 October 2012
        prj <- matrix(c(albers_conical_equal_area, aea, azimuthal_equidistant, aeqd, lambert_cylindrical_equal_area, cea, lambert_azimuthal_equal_area, laea, lambert_conformal_conic, lcc, latitude_longitude, longlat, mercator, merc, orthographic, ortho, polar_stereographic, stere, stereographic, stere, transverse_mercator, tmerc), ncol=2, byrow=TRUE)

        m <- matrix(c(grid_mapping_name, +proj, false_easting, +x_0,false_northing, +y_0, scale_factor_at_projection_origin, +k_0, scale_factor_at_central_meridian, +k_0, standard_parallel, +lat_1, standard_parallel1, +lat_1, standard_parallel2, +lat_2, longitude_of_central_meridian, +lon_0, longitude_of_projection_origin, +lon_0, latitude_of_projection_origin, +lat_0, straight_vertical_longitude_from_pole, +lon_0,
        longitude_of_prime_meridian, +lon_0, semi_major_axis, +a, inverse_flattening, +rf), ncol=2, byrow=TRUE)

        sp <- g$standard_parallel
        if (!is.null(sp)) {
                if (length(sp) > 1) {
                        g$standard_parallel1 <- sp[1]
                        g$standard_parallel2 <- sp[2]
                        g$standard_parallel <- NULL
                }
        }
        vals <- unlist(g)
        vars <- names(g)
        i <- match(vars, m[,1])
        if (any(is.na(i))) {
                warning(could not process the CRS)
                print(as.matrix(g))
                return(NA)
        }
        tab <- cbind(m[i,], vals)
        j <- match(tab[1,3], prj[,1])
        tab[1,3] <- prj[j,2]
        paste(apply(tab[,2:3], 1, function(x)paste(x, collapse='=')), collapse=' ')
}
.NCDFversion4 <- function() {
        loadNCDF <- function() {
                if (!require(ncdf)) {
                        stop('To open ncdf files, you need to first install package ncdf or ncdf4') 
                }
                options(rasterNCDF4 = FALSE)
                return(FALSE)
        }

        ncdf4 <- getOption('rasterNCDF4')
        if (is.null(ncdf4)) {
                if (length(find.package(ncdf4, quiet=TRUE)) > 0) {
                        if (require(ncdf4, quietly=TRUE)) {
                                options(rasterNCDF4 = TRUE)
                                ncdf4 <- TRUE

                        } else {
                                ncdf4 <- loadNCDF()
                        }

                } else {
                        ncdf4 <- loadNCDF()
                }
        }
        return(ncdf4)
}
.isNetCDF <- function(x) {
        on.exit(options('warn'= getOption('warn')))
        options('warn'=-1) 
        fcon <- file(x, rb)
        tst <- try( w <- readBin(fcon, what='character', n=1), silent=TRUE)
        close(fcon)
        if ( isTRUE((substr(w, 1, 3) == CDF ))) { return(TRUE) 
        } else { return(FALSE)
        }
}
.getRasterDTypeFromCDF <- function(type) { 
        if (type == char )  { return(INT1U) 
        } else if (type == byte ) { return(INT1S)
        } else if (type == short ) { return(INT2S)
        } else if (type == int ) { return(INT4S)
        } else if (type == integer ) { return(INT4S)
        } else if (type == float ) { return(FLT4S)
        } else if (type ==double ) { return(FLT8S) 
        } else { return(FLT4S) }
}
.getNetCDFDType <- function(dtype) {
        if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'))) {
                stop('not a valid data type')
        }
        type <- tolower(.shortDataType(dtype))
        size <- dataSize(dtype) * 8
        signed <- dataSigned(dtype)

        if (size == 8) {
                if (!signed) {
                        return(char) #8-bit characters intended for representing text.
                } else {
                        return(byte)
                }
        } else if (type == 'integer') {
                if (!signed) {
                        warning('netcdf only stores signed integers')
                }
                if (size == 16) { 
                        return( short ) 
                } else if (size == 32 ) { 
                        return( integer ) 
                } else {
                        return ( double )               
                }
        } else {
                if (size == 32) { 
                        return( float ) 
                } else {  
                        return ( double )  
                }
        }
}

173 netCDFwriteCD.R

# Author: Robert J. Hijmans
# Date: June 2010
# Version 1.0
# Licence GPL v3
.startWriteCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, att, 
                varname, varunit, varatt, longname, xname, yname, zname, zunit, zatt, NAflag, ...) {

        ncdf4 <- .NCDFversion4()

        filename = trim(filename)
        if (filename == '') { stop('provide a filename') }
        extension(filename) <- .defaultExtension(format='CDF')
        if (file.exists(filename) & !overwrite) {
                stop('file exists, use overwrite=TRUE to overwrite it')
        }
        dataType(x) <- datatype
        datatype <- .getNetCDFDType(datatype)
        nl <- nlayers(x)

        if (couldBeLonLat(x)) {
                if (missing(xname)) xname = 'longitude'
                if (missing(yname)) yname = 'latitude'
                xunit = 'degrees_east'
                yunit = 'degrees_north'
        } else {
                if (missing(xname)) xname = 'easting'
                if (missing(yname)) yname = 'northing'
                xunit = 'meter' # probably
                yunit = 'meter' # probably
        }

        if (missing(zunit)) {
                zunit <- 'unknown'
        }
        if (missing(zname)) {
                zname <- 'value'
        }
        if (missing(varname))  {
                if (nl == 1) {
                        varname <- names(x)
                } else if (!is.null(names(x@z))) {
                        varname <- names(x@z)
                } else {
                        varname <- 'variable'
                }
        }       
        x@title <- varname
        if (missing(varunit))  varunit <- ''
        if (missing(longname))  longname <- varname

        if (ncdf4) {

                xdim <- ncdf4::ncdim_def( xname, xunit, xFromCol(x, 1:ncol(x)) )
                ydim <- ncdf4::ncdim_def( yname, yunit, yFromRow(x, 1:nrow(x)) )
                if (inherits(x, 'RasterBrick')) {
                        zv <- 1:nl
                        z <- getZ(x)
                        if (!is.null(z)) {
                                if (!any(is.na(z))) {
                                        z <- as.numeric(z)
                                        if (!any(is.na(z))) {
                                                zv[] <- z
                                        } else {
                                                warning('z-values cannot be converted to numeric')
                                        }
                                } else {
                                        warning('z-values contain NA')
                                }
                        }
                        zdim <- ncdf4::ncdim_def( zname, zunit, zv, unlim=TRUE )
                        vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim,ydim,zdim), NAvalue(x), prec = datatype )
                        #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), -3.4e+38 )
                } else {
                        #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), -3.4e+38 )
                        vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim,ydim), NAvalue(x), prec = datatype )
                }
                nc <- ncdf4::nc_create(filename, vardef)
                if (! missing(zatt)){
                        for (i in 1:length(zatt)) {
                                a <- trim(unlist(strsplit(zatt[i], '=')))
                                ncdf4::ncatt_put(nc, zname, a[1], a[2]) 
                        }
                }
                if (!missing(NAflag)) {
                        x@file@nodatavalue <- NAflag
                } 

                ncdf4::ncatt_put(nc, varname, '_FillValue', x@file@nodatavalue)
                ncdf4::ncatt_put(nc, varname, 'missing_value', x@file@nodatavalue)
                ncdf4::ncatt_put(nc, varname, 'long_name', longname)
                proj <- projection(x) 
                if (! is.na(proj)) { 
                        ncdf4::ncatt_put(nc, varname, 'projection', proj)
                        ncdf4::ncatt_put(nc, varname, 'projection_format', 'PROJ.4')
                }
                if (! missing(varatt)){
                        for (i in 1:length(varatt)) {
                                a <- trim(unlist(strsplit(varatt[i], '=')))
                                ncdf4::ncatt_put(nc, varname, a[1], a[2])       
                        }
                }
                ncdf4::ncatt_put(nc, 0, 'Conventions', 'CF-1.4')
                if (! missing(att)){
                        for (i in 1:length(att)) {
                                a <- trim(unlist(strsplit(att[i], '=')))
                                ncdf4::ncatt_put(nc, 0, a[1], a[2])     
                        }
                }

                pkgversion <- drop(read.dcf(file=system.file(DESCRIPTION, package='raster'), fields=c(Version)))
                ncdf4::ncatt_put(nc, 0, 'created_by', paste('R, packages ncdf and raster (version ', pkgversion, ')', sep=''))
                ncdf4::ncatt_put(nc, 0, 'date', format(Sys.time(), %Y-%m-%d %H:%M:%S))
                ncdf4::nc_close(nc)

        } else {  # library(ncdf)

                xdim <- ncdf::dim.def.ncdf( xname, xunit, xFromCol(x, 1:ncol(x)) )
                ydim <- ncdf::dim.def.ncdf( yname, yunit, yFromRow(x, 1:nrow(x)) )
                if (inherits(x, 'RasterBrick')) {
                        zv <- 1:nl
                        z <- getZ(x)
                        if (!is.null(z)) {
                                if (!any(is.na(z))) {
                                        z <- as.numeric(z)
                                        if (!any(is.na(z))) {
                                                zv[] <- z
                                        } else {
                                                warning('z-values cannot be converted to numeric')
                                        }
                                } else {
                                        warning('z-values contain NA')
                                }
                        }
                        zdim <- ncdf::dim.def.ncdf( zname, zunit, zv, unlim=TRUE )
                        vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), NAvalue(x), prec = datatype )
                        #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim,zdim), -3.4e+38 )
                } else {
                        #vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), -3.4e+38 )
                        vardef <- ncdf::var.def.ncdf( varname, varunit, list(xdim,ydim), NAvalue(x), prec = datatype )
                }
                nc <- ncdf::create.ncdf(filename, vardef)
                if (! missing(zatt)){
                        for (i in 1:length(zatt)) {
                                a <- trim(unlist(strsplit(zatt[i], '=')))
                                ncdf::att.put.ncdf(nc, zname, a[1], a[2])       
                        }
                }
                if (!missing(NAflag)) {
                        x@file@nodatavalue <- NAflag
                } 

                ncdf::att.put.ncdf(nc, varname, '_FillValue', x@file@nodatavalue)
                ncdf::att.put.ncdf(nc, varname, 'missing_value', x@file@nodatavalue)
                ncdf::att.put.ncdf(nc, varname, 'long_name', longname)
                proj <- projection(x) 
                if (! is.na(proj)) { 
                        ncdf::att.put.ncdf(nc, varname, 'projection', proj)
                        ncdf::att.put.ncdf(nc, varname, 'projection_format', 'PROJ.4')
                }
                if (! missing(varatt)){
                        for (i in 1:length(varatt)) {
                                a <- trim(unlist(strsplit(varatt[i], '=')))
                                ncdf::att.put.ncdf(nc, varname, a[1], a[2])     
                        }
                }
                ncdf::att.put.ncdf(nc, 0, 'Conventions', 'CF-1.4')
                if (! missing(att)){
                        for (i in 1:length(att)) {
                                a <- trim(unlist(strsplit(att[i], '=')))
                                ncdf::att.put.ncdf(nc, 0, a[1], a[2])   
                        }
                }

                pkgversion = drop(read.dcf(file=system.file(DESCRIPTION, package='raster'), fields=c(Version)))
                ncdf::att.put.ncdf(nc, 0, 'created_by', paste('R, packages ncdf and raster (version ', pkgversion, ')', sep=''))
                ncdf::att.put.ncdf(nc, 0, 'date', format(Sys.time(), %Y-%m-%d %H:%M:%S))
                ncdf::close.ncdf(nc)
        }

        x@data@min <- rep(Inf, nl)
        x@data@max <- rep(-Inf, nl)
        x@data@haveminmax <- FALSE
        x@file@driver <- 'netcdf'
        x@file@name <- filename

        return(x)
}
.stopWriteCDF <-  function(x) {
        if (getOption('rasterNCDF4')) {
                nc <- ncdf4::nc_open(x@file@name, write=TRUE)
                on.exit( ncdf4::nc_close(nc) )
                ncdf4::ncatt_put(nc, x@title, 'min', as.numeric(x@data@min))
                ncdf4::ncatt_put(nc, x@title, 'max', as.numeric(x@data@max))
        } else {
                nc <- ncdf::open.ncdf(x@file@name, write=TRUE)
                on.exit( ncdf::close.ncdf(nc) )
                ncdf::att.put.ncdf(nc, x@title, 'min', as.numeric(x@data@min))
                ncdf::att.put.ncdf(nc, x@title, 'max', as.numeric(x@data@max))
        }
        if (inherits(x, 'RasterBrick')) {
                r <- brick(x@file@name)
        } else {
                r <- raster(x@file@name)
        }

        return(r)
}
.writeValuesCDF <- function(x, v, start=1) {
        rsd <- na.omit(v) 
        if (length(rsd) > 0) {
                x@data@min <- min(x@data@min, rsd)
                x@data@max <- max(x@data@max, rsd)
        }       

        v[is.na(v)] <- x@file@nodatavalue
        nr <- length(v) / x@ncols
        v <- matrix(v, ncol=nr)
        if (getOption('rasterNCDF4')) {
                nc <- ncdf4::nc_open(x@file@name, write=TRUE)
                on.exit( ncdf4::nc_close(nc) )
                try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) )
        } else {
                nc <- ncdf::open.ncdf(x@file@name, write=TRUE)
                try ( ncdf::put.var.ncdf(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) )
                ncdf::close.ncdf(nc)
        }
        return(x)
}
.writeValuesBrickCDF <- function(x, v, start=1, layer) {
        if (missing(layer)) { 
                nl <- nlayers(x)
                lstart <- 1
                lend <- nl
                w <- getOption('warn')
                options('warn'=-1) 
                rsd <- apply(v, 2, range, na.rm=TRUE)
                x@data@min <- pmin(x@data@min, rsd[1,])
                x@data@max <- pmax(x@data@max, rsd[2,])
                options('warn'= w)              
        } else { 
                nl <- 1
                lstart <- layer
                lend <- layer   
                rsd <- na.omit(v) 
                if (length(rsd) > 0) {
                        x@data@min[layer] <- min(x@data@min[layer], rsd)
                        x@data@max[layer] <- max(x@data@max[layer], rsd)
                }                       
        }
        ncols <- x@ncols
        v[is.na(v)] = x@file@nodatavalue
        rows <- length(v) / (ncols * nl)
        v <- array(v, c(rows, ncols, nl))
        if (getOption('rasterNCDF4')) {
                nc <- ncdf4::nc_open(x@file@name, write=TRUE)
                on.exit( ncdf4::nc_close(nc) )
                try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) )
        } else {
                nc <- ncdf::open.ncdf(x@file@name, write=TRUE)
                try ( ncdf::put.var.ncdf(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) )
                ncdf::close.ncdf(nc)
        }

        return(x)
}
#.rasterSaveAsNetCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, ...) {
#       x <- .startWriteCDF(x, filename=filename, datatype=datatype, overwrite=overwrite, ...)
#       if (nlayers(x) > 1) {
#               x <- .writeValuesBrickCDF(x, getValues(x) )     
#       } else {
#               x <- .writeValuesCDF(x, getValues(x))
#       }
#       return( .stopWriteCDF(x) )
#}
#library(raster)
#r = raster(ncol=10, nrow=5)
#r[] = c(1:49, NA)
#names(r) = 'hello world'
#a = .rasterSaveAsNetCDF(r, 'test.nc', overwrite=TRUE)
#plot(a)
#print(a)

174 newPLot.R

# The functions below here were adapted from the functions in the fields package! (image.plot and subroutines)
# fields, Tools for spatial data
# Copyright 2004-2007, Institute for Mathematics Applied Geosciences
# University Corporation for Atmospheric Research
# Licensed under the GPL -- www.gpl.org/licenses/gpl.html
# Adaptations for the raster package:
# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  May 2010
# Version 1.0
# Licence GPL v3
.plotSpace <- function(asp=1, legend.mar = 3.1, legend.width = 0.5, legend.shrink = 0.5) {

        par <- par()
        char.size <- par$cin[1] / par$din[1]
    offset <- char.size * par$mar[4] 
    legend.width <- char.size * legend.width
    legend.mar <- legend.mar * char.size
        legendPlot = par$plt
        legendPlot[2] <- 1 - legend.mar
    legendPlot[1] <- legendPlot[2] - legend.width
    pr <- (legendPlot[4] - legendPlot[3]) * ((1 - legend.shrink)/2)
    legendPlot[4] <- legendPlot[4] - pr
    legendPlot[3] <- legendPlot[3] + pr

    bp <- par$plt
    bp[2] <- min(bp[2], legendPlot[1] - offset)
        aspbp = (bp[4]-bp[3]) / (bp[2]-bp[1])
        adj = aspbp / asp
        if (adj < 1) {
                adjust = (bp[4]-bp[3]) - ((bp[4]-bp[3]) * adj)
        } else {
                adjust = (bp[4]-bp[3]) / adj - ((bp[4]-bp[3]))  
        }
        adjust = adjust / 2
bp
        bp[3] = bp[3] + adjust
        bp[4] = bp[4] - adjust  
  bp

        dp <- legendPlot[2] - legendPlot[1]
    legendPlot[1] <- min(bp[2] + 0.5 * offset, legendPlot[1])
    legendPlot[2] <- legendPlot[1] + dp
    return(list(legendPlot = legendPlot, mainPlot = bp))
}
.plotLegend <- function(z, col, legend.at='classic', lab.breaks = NULL, axis.args = NULL, legend.lab = NULL, legend.args = NULL, ...) {
                horizontal=FALSE
                ix <- 1
                zlim <- range(z, na.rm = TRUE, finite=TRUE)
                zrange <- zlim[2]-zlim[1]
                if (zrange > 10) { decs <- 0
                } else  if (zrange > 1) { decs <- 1
                } else { decs <- ceiling(abs(log10(zrange)) + 1) } 
                pow <- 10^decs
                minz <- floor(zlim[1] * pow) / pow
                maxz <- ceiling(zlim[2] * pow) / pow
                zrange <- maxz - minz

                nlevel = length(col)
                binwidth <- c(0, 1:nlevel * (1/nlevel))
                iy <- minz + zrange * binwidth
#               binwidth <- 1 + (maxz - minz)/nlevel
#               iy <- seq(minz, maxz, by = binwidth)
                iz <- matrix(iy, nrow = 1, ncol = length(iy))
                breaks <- list(...)$breaks


                if (!is.null(breaks) & !is.null(lab.breaks)) {
                        axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args)                    
                } else {
                        if (legend.at == 'quantile') {
                                z <- z[is.finite(z)]
                                at = quantile(z, names=F, na.rm=TRUE)
                                axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args)                               
#                               at <- c(0, 1:5 * (1/5))
#                               at <- minz + zrange * at
                        } else {
                                at <- axTicks(2, c(minz, maxz, 4))
                        }
                        at <- round(at, decs)
                        axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args)                                               
                }

                if (!horizontal) {
                        if (is.null(breaks)) {
                                image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col = col)
                        } else {
                                image(ix, iy, iz, xaxt=n, yaxt=n, xlab = , ylab = , col = col, breaks = breaks)
                        }
                } else {
                        if (is.null(breaks)) {
                                image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col)
                        } else {
                                image(iy, ix, t(iz), xaxt = n, yaxt = n, xlab = , ylab = , col = col, breaks = breaks)
                        }
                }
                axis.args = c(axis.args, cex.axis=0.75, tcl=-0.15, list(mgp=c(3, 0.4, 0)) )
                do.call(axis, axis.args)
                #axis(axis.args$side, at=min(iz), las=ifelse(horizontal, 0, 2))
                box()

                # title(main = list(legend.lab, cex=1, font=1))
                if (!is.null(legend.lab)) {
                        # mtext(legend.lab, side=3, line=0.75)
                        #legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2)
                        legend.args <- list(text = legend.lab, side=3, line=0.75)
                }
                if (!is.null(legend.args)) {
                        #do.call(mtext, legend.args)
                }
        }
.plot2 <- function(x, maxpixels=100000, col=rev(terrain.colors(25)), xlab='', ylab='', asp, box=TRUE, add=FALSE, legend=TRUE, legend.at='', ...)  {

        if (!add & missing(asp)) {
                if (couldBeLonLat(x)) {
                        ym <- mean(x@extent@ymax + x@extent@ymin)
                        asp <- min(5, 1/cos((ym * pi)/180))
                } else {
                        asp = 1
                }               
        }
        plotArea <- .plotSpace(asp)
        x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE)
        xticks <- axTicks(1, c(xmin(x), xmax(x), 4))
        yticks <- axTicks(2, c(ymin(x), ymax(x), 4))

        if (xres(x) %% 1 == 0) xticks = round(xticks)
        if (yres(x) %% 1 == 0) yticks = round(yticks)
        y <- yFromRow(x, nrow(x):1)
        z <- t((getValues(x, format='matrix'))[nrow(x):1,])
        x <- xFromCol(x,1:ncol(x))
        if (add) { 
                image(x=x, y=y, z=z,  col=col, axes=FALSE, xlab=xlab, ylab=ylab, add=TRUE, ...)
        } else {
                if (legend) {
                        par(pty = m, plt=plotArea$legendPlot, err = -1)
                        .plotLegend(z, col, legend.at=legend.at, ...)
                        par(new=TRUE, plt=plotArea$mainPlot) 
                }
                image(x=x, y=y, z=z,  col=col, axes=FALSE, xlab=xlab, ylab=ylab, asp=asp, ...)
                axis(1, at=xticks,  cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.25, 0))
                las = ifelse(max(nchar(as.character(yticks)))> 5, 0, 1)
                axis(2, at=yticks, las = las,  cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.75, 0) )
                #axis(3, at=xticks, labels=FALSE, lwd.ticks=0)
                #axis(4, at=yticks, labels=FALSE, lwd.ticks=0)
                if (box) box()
        }
}
#.plot2(r, legend=T)
# .plot2(r, legend.at='quantile')
# plot(wrld_simpl, add=T)

175 nlayers.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 1.0
# Licence GPL v3
if (!isGeneric(nlayers)) {
        setGeneric(nlayers, function(x)
                standardGeneric(nlayers))
}       
setMethod('nlayers', signature(x='BasicRaster'), 
        function(x){
                return(0) 
    }
)
setMethod('nlayers', signature(x='Raster'), 
        function(x){
                return(1) 
    }
)
setMethod('nlayers', signature(x='RasterStack'), 
        function(x){
                as.integer( sum(unlist( sapply(x@layers, nlayers) ) ) )
    }
)
setMethod('nlayers', signature(x='RasterBrick'), 
        function(x){
                return(x@data@nlayers) 
    }
)
setMethod('nlayers', signature(x='Spatial'), 
        function(x){
                if (! is.null( attr(x, 'data') ) ) {
                        return( dim(x@data)[2] ) 
                } else {
                        return( 0 )
                }
    }
)

176 notused.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
# Not used
.writeRasterAssign <- function(x, filename, ...) {
        name <- deparse(substitute(x))
        x <- writeRaster(x, filename, ...)
        assign(name, x, envir=parent.frame())
        return(invisible())
}
.writeSparse <- function(raster, filename, overwrite=FALSE) {
#       raster@file@driver <- 'raster'
        if (!overwrite & file.exists(filename)) {
                stop(filename, exists. Use 'overwrite=TRUE' if you want to overwrite it) 
        }
        raster@data@values[is.nan(raster@data@values)] <- NA
        dtype <- .shortDataType(raster@data@datanotation)
        if (dtype == integer) { 
                raster@data@values <- as.integer(raster@data@values) 
        }
        if (class(raster@data@values)=='integer') {
                dataType(raster) <- 'INT4S'
        }       
        raster <- setMinMax(raster)
        binraster <- .setFileExtensionValues(raster@file@name, 'raster')
        raster <- readStart(raster)
        writeBin( as.vector(raster@data@indices), raster@file@con, size = as.integer(4)) 
        writeBin( as.vector(raster@data@values), raster@file@con, size = dataSize(raster@file@datanotation) ) 
        raster <- readStop(raster)
        # add the 'sparse' key word to the hdr file!!!
        hdr(raster) 
        return(raster)
}

177 nsidcICE.R

.rasterFromNSIDCFile <- function(x) {
    ## check name structure
    ## nt_19781119_f07_v01_s.bin
    bx <- basename(x)
    ## test that we can get a date from this
    ## (as POSIXct so that Z-comparisons are more natural)
    dts <- as.POSIXct(basename(x), format = nt_%Y%m%d, tz = GMT)
    ## test that we see _f and _v
    fyes <- tolower(substr(bx, 13L, 13L)) %in% c(f, n)
    vyes <- tolower(substr(bx, 17L, 17L)) %in% c(v, n)
    ## finally, it's north or south
    hemi <- tolower(substr(bx, 21L, 21L))
    hyes <- hemi %in% c(s, n)
    if(!(!is.na(dts) & fyes & vyes & hyes)) return(NULL)
    ## NSIDC projection and grid size
    ## https://nsidc.org/data/polar_stereo/ps_grids.html
    ## http://spatialreference.org/ref/?search=nsidc
    ## Hughes 1980 ellipsoid, True Scale Lat is +/-70
    if (hemi == s) {
        prj <-  +proj=stere +lat_0=-90 +lat_ts=-70 +lon_0=0 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs
        dims <- c(316L, 332L)
        ext <- c(-3950000, 3950000, -3950000, 4350000)
    } else {
        ## northern hemisphere
        prj <- +proj=stere +lat_0=90 +lat_ts=70 +lon_0=-45 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs
        dims <- c(304, 448)
        ext <- c(-3837500, 3762500, -5362500, 5837500)
    }
    on.exit(close(con))
    con <- file(x, open = rb)
    ## chuck the header
    try1 <- try(trash <- readBin(con, integer, size = 1, n = 300))
    ## TODO: warnings that we thought it was NSIDC, but it did not work?
    if (inherits(try1, try-error)) return(NULL)
    dat <- try(readBin(con, integer, size = 1, n = prod(dims), endian = little, signed = FALSE))
    if (inherits(dat, try-error)) return(NULL)
    r100 <- dat > 250
    r0 <- dat < 1
##      if (rescale) {
        dat <- dat/2.5  ## rescale back to 100
##      }
##      if (setNA) {
        dat[r100] <- NA
        dat[r0] <- NA
##      }
    r <- raster(t(matrix(dat, dims[1])), xmn=ext[1], xmx=ext[2], ymn=ext[3], ymx=ext[4], crs = prj)
    setZ(r, dts, name = time)
}

178 origin.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  October 2008
# Version 0.9
# Licence GPL v3
if (!isGeneric(origin)) {
        setGeneric(origin, function(x, ...)
                standardGeneric(origin))
}
setMethod('origin', signature(x='BasicRaster'), 
function(x, ...) {
        e <- x@extent
        r <- res(x)
        x <- e@xmin - r[1]*(round(e@xmin / r[1]))
        y <- e@ymax - r[2]*(round(e@ymax / r[2]))

        if (isTRUE(all.equal((r[1] + x), abs(x)))) {
                x <- abs(x)
        }
        if (isTRUE(all.equal((r[2] + y), abs(y)))) {
                y <- abs(y)
        }
        return(c(x, y))
}
)
if (!isGeneric(origin<-)) {
        setGeneric(origin<-, function(x, value)
                standardGeneric(origin<-))
}
setMethod(origin<-, signature('BasicRaster'), 
        function(x, value) {
                value <- rep(value, length.out=2)
                dif <- value - origin(x)
                res <- res(x)
                dif[1] <- dif[1] %% res[1]
                dif[2] <- dif[2] %% res[2]
                for (i in 1:2) {
                        if (dif[i] < 0) {
                                if ((dif[i] + res[i]) < abs(dif[i])) {
                                        dif[i] <- dif[i] + res[i]
                                }
                        } else {
                                if (abs(dif[i] - res[i]) < dif[i]) {
                                        dif[i] <- dif[i] - res[i]
                                }
                        }
                }
                e <- extent(x)
                e@xmin <- e@xmin + dif[1]
                e@xmax <- e@xmax + dif[1]               
                e@ymin <- e@ymin + dif[2]
                e@ymax <- e@ymax + dif[2]               
                x@extent <- e
                return(x)
        }
)

179 overlay.R

# Author: Robert J. Hijmans, r.hijmans@gmail.com
# Date :  June 2008
# Version 0.9
# Licence GPL v3
# version 1, April 2012
setMethod('overlay', signature(x='Raster', y='Raster'), 
function(x, y, ..., fun, filename=, recycle=TRUE){ 
        if (missing(fun)) { 
                stop(you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum') 
        }
        lst <- list(...)
        isRast <- sapply(lst, function(x) inherits(x, 'Raster'))
        if (sum(unlist(isRast)) > 0) {
                x <- c(x, y, lst[isRast])
                lst <- lst[! isRast ]
        } else {
                x <- list(x, y)
        }
        lst$fun <- fun
        lst$filename <- filename
        lst$recycle <- recycle
        lst$x <- x
        do.call(.overlayList, lst)
}
)
setMethod('overlay', signature(x='Raster', y='missing'), 
function(x, y, ..., fun, filename=, unstack=TRUE){ 
        if (missing(fun)) { 
                stop(you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum') 
        }

        x <- .makeRasterList(x, unstack=unstack)        
        .overlayList(x, fun=fun, filename=filename, ...)
}
)
.overlayList <- function(x, fun, filename=, recycle=TRUE, ...){ 


        ln <- length(x)
        if (ln < 1) { 
                stop('no Rasters') 
        }
        if (ln > 2) { 
                compareRaster(x) 
        }

        nl <- sapply(x, nlayers)
        maxnl <- max(nl)
        filename <- trim(filename)
        testmat <- NULL
        testlst <- vector(length=length(x), mode='list')
        w <- getOption('warn')
        options('warn'=-1) 
        for (i in 1:length(testlst)) {
                v <- extract(x[[i]], 1:5)
                testmat <- cbind(testmat, as.vector(v))
                testlst[[i]] <- v
        }
        options('warn'= w) 
        test1 <- try ( apply(testmat, 1, fun) , silent=TRUE )
        if (class(test1) != try-error) {
                doapply <- TRUE
                if (! is.null(dim(test1))) {
                        test1 <- t(test1)
                } else {
                        test1 <- matrix(test1, ncol=maxnl)
                }
                nlout <- NCOL(test1)
        } else {
                doapply <- FALSE
                dovec <- FALSE
                test2 <- try ( do.call(fun, testlst), silent=TRUE )
                nlout <- length(test2)/5
                if (class(test2) == try-error | length(test2) < 5) {
                        dovec <- TRUE
                        testlst <- lapply(testlst, as.vector)
                        test3 <- try ( do.call(fun, testlst), silent=TRUE )
                        nlout <- length(test3)/5
                        if (class(test3) == try-error | length(test3) < 5) {
                                stop('cannot use this formula, probably because it is not vectorized')
                        }
                } 
        }
        if (nlout == 1) {
                out <- raster(x[[1]])
        } else {
                out <- brick(x[[1]], values=FALSE, nl=nlout)
        }

        if ( canProcessInMemory(out, sum(nl)+maxnl) ) {
                pb <- pbCreate(3, label='overlay', ...)                 
                pbStep(pb, 1)
                if (doapply) {
                        valmat <- matrix(nrow=ncell(out)*maxnl, ncol=length(x)) 
                        for (i in 1:length(x)) {
                                if (ncell(x[[i]]) < nrow(valmat)) {
                                        options('warn'=-1) 
                                        valmat[,i] <- as.vector(getValues(x[[i]])) * rep(1, nrow(valmat))
                                        options('warn'= w) 
                                } else {
                                        valmat[,i] <- as.vector(getValues(x[[i]]))
                                }
                        }
                        pbStep(pb, 2)
                        vals <- apply(valmat, 1, fun)
                        if (! is.null(dim(vals))) {
                                vals <- t(vals)
                        }
                        vals <- matrix(vals, nrow=ncell(out))

                } else {
                        for (i in 1:length(x)) {
                x[[i]] <- getValues(x[[i]])
            }
                        if (dovec) {
                                x <- lapply(x, as.vector)
                        }
                        pbStep(pb, 2)
                        vals <- do.call(fun, x)
                        vals <- matrix(vals, nrow=ncell(out))
                }
                pbStep(pb, 3)
                out <- setValues(out, vals)
                if (filename != ) { 
                        out <- writeRaster(out, filename=filename, ...) 
                }
                pbClose(pb)
                return(out)

        } else {

                if (filename == ) {
                        filename <- rasterTmpFile()
                } 
                out <- writeStart(out, filename=filename, ...)


                tr <- blockSize(out, n=sum(nl)+maxnl)
                pb <- pbCreate(tr$n, label='overlay', ...)

                if (doapply) { 
                        valmat = matrix(nrow=tr$nrows[1]*ncol(out)*maxnl, ncol=length(x)) 
                        for (i in 1:tr$n) {
                                if (i == tr$n) {
                                        valmat = matrix(nrow=tr$nrows[i]*ncol(out)*maxnl , ncol=length(x))
                                }
                                for (j in 1:length(x)) {
                                        v <- as.vector(getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]))
                                        if (length(v) < nrow(valmat)) {
                                                options('warn'=-1) 
                                                valmat[,j] <- v * rep(1, nrow(valmat))
                                                options('warn'=w) 
                                        } else {
                                                valmat[,j] <- v
                                        }
                                }       

                                vv <- apply(valmat, 1, fun)
                                if (! is.null(dim(vv))) {
                                        vals <- t(vv)
                                }
                                vv <- matrix(vv, ncol=nlout)
                                out <- writeValues(out, vv, tr$row[i])
                                pbStep(pb, i)
                        }

                } else {
                        vallist <- list()
                        for (i in 1:tr$n) {
                                if (dovec) {
                                        for (j in 1:length(x)) {
                                                vallist[[j]] <- as.vector( getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) )
                                        }       
                                } else {
                                        for (j in 1:length(x)) {
                                                vallist[[j]] <- getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i])
                                        }
                                }       
                                vv <- do.call(fun, vallist)
                                vv <- matrix(vv, ncol=nlout)
                                out <- writeValues(out, vv, tr$row[i])
                                pbStep(pb, i)
                        }
                }
                pbClose(pb)
                out <- writeStop(out)
        } 
        return(out)
}

Last Updated .